crmPack coverage - 79.18%

Files
Source

# nolint start
#####################################################################################
## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com],
##         Wai Yin Yeung [ w *.* yeung1 *a*t* lancaster *.* ac *.* uk]
## Project: Object-oriented implementation of CRM designs
##
## Time-stamp: <[Simulations-methods.R] by DSB Fre 16/01/2015 13:41>
##
## Description:
## Methods for handling the simulations output.
##
## History:
## 19/02/2014   file creation
## 30/07/2014   added in methods for pseudo models simulations
###################################################################################


##' @include Simulations-class.R
##' @include helpers.R
{}


##' Plot simulations
##'
##' Summarize the simulations with plots
##'
##' This plot method can be applied to \code{\linkS4class{GeneralSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} } You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{GeneralSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMsingle.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "GeneralSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## start the plot list
      plotList <- list()
      plotIndex <- 0L


      ## summary of the trajectories
      if ("trajectory" %in% type) {
        ## get a matrix of the simulated dose trajectories,
        ## where the rows correspond to the simulations and
        ## the columns to the patient index:

        ## If design with placebo, then exclude placebo Patients
        if (x@data[[1]]@placebo) {
          PL <- x@data[[1]]@doseGrid[1]
          simDoses <- lapply(
            x@data,
            function(y) {
              y@x[y@x != PL]
            }
          )
        } else {
          simDoses <- lapply(
            x@data,
            slot,
            "x"
          )
        }

        maxPatients <- max(sapply(simDoses, length))

        simDosesMat <- matrix(
          data = NA,
          nrow = length(simDoses),
          ncol = maxPatients
        )

        for (i in seq_along(simDoses))
        {
          simDosesMat[i, seq_along(simDoses[[i]])] <-
            simDoses[[i]]
        }


        ## extract statistics
        stats <- c(
          "Minimum",
          "Lower Quartile",
          "Median",
          "Upper Quartile",
          "Maximum"
        )
        traj.df <-
          data.frame(
            patient =
              rep(seq_len(maxPatients), each = 5L),
            Statistic =
              factor(
                rep(
                  stats,
                  maxPatients
                ),
                levels = stats
              ),
            traj =
              c(apply(simDosesMat, 2L, quantile,
                na.rm = TRUE
              ))
          )

        ## linetypes for the plot
        lt <- c(
          "Median" = 1,
          "Lower Quartile" = 2,
          "Upper Quartile" = 2,
          "Minimum" = 4,
          "Maximum" = 4
        )

        ## save the plot
        if (x@data[[1]]@placebo) {
          myTitle <- "Patient (placebo were excluded)"
        } else {
          myTitle <- "Patient"
        }
        plotList[[plotIndex <- plotIndex + 1L]] <-
          ggplot() +
          geom_step(
            aes(
              x = patient,
              y = traj,
              group = Statistic,
              linetype = Statistic
            ),
            size = 1.2, colour = "blue", data = traj.df
          ) +
          ## scale_linetype_manual(values=lt) +
          xlab(myTitle) +
          ylab("Dose Level")
      }

      ## average distribution of the doses tried
      if ("dosesTried" %in% type) {
        ## get the doses tried
        simDoses <- lapply(
          x@data,
          slot,
          "x"
        )

        ## get the dose distributions by trial
        doseDistributions <-
          sapply(
            simDoses,
            function(s) {
              if (length(s) > 0) {
                prop.table(table(factor(s, levels = x@data[[1]]@doseGrid)))
              } else {
                rep(0, length(x@data[[1]]@doseGrid))
              }
            }
          )

        ## derive the average dose distribution across trial
        ## simulations
        averageDoseDist <- rowMeans(doseDistributions)

        ## get in data frame shape
        dat <- data.frame(
          dose = as.numeric(names(averageDoseDist)),
          perc = averageDoseDist * 100
        )

        ## produce and save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          ggplot() +
          geom_bar(
            data = as.data.frame(dat),
            aes(x = dose, y = perc),
            stat = "identity",
            position = "identity",
            width = min(diff(x@data[[1]]@doseGrid)) / 2
          ) +
          xlab("Dose level") +
          ylab("Average proportion [%]")
      }
      ## then finally plot everything

      ## if there is only one plot
      if (identical(
        length(plotList),
        1L
      )) {
        ## just return it
        return(plotList[[1L]])
      } else {
        ## otherwise arrange them
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
        return(ret)
      }
    }
)


##' Plot dual-endpoint simulations
##'
##' This plot method can be applied to \code{\linkS4class{DualSimulations}}
##' objects in order to summarize them graphically. In addition to the standard
##' plot types, there is
##' \describe{
##' \item{sigma2W}{Plot a boxplot of the final biomarker variance estimates in
##' the simulated trials}
##' \item{rho}{Plot a boxplot of the final correlation estimates in
##' the simulated trials}
##' }
##'
##' @param x the \code{\linkS4class{DualSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 qplot coord_flip scale_x_discrete
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-DualSimulations.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "DualSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried",
                 "sigma2W",
                 "rho"
               ),
             ...) {
      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for
      ## dual-endpoint simulation results
      typeReduced <- setdiff(
        type,
        c("sigma2W", "rho")
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## now to the specific dual-endpoint plots:

      ## biomarker variance estimates boxplot
      if ("sigma2W" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@sigma2w_est), geom = "boxplot",
            xlab = "", ylab = "Biomarker variance estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }

      ## correlation estimates boxplot
      if ("rho" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@rho_est), geom = "boxplot",
            xlab = "", ylab = "Correlation estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }

      ## then finally plot everything
      if (identical(
        length(plotList),
        0L
      )) {
        return(genPlot)
      } else if (identical(
        length(plotList),
        1L
      )) {
        ret <- plotList[[1L]]
      } else {
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
      }

      if (moreFromGeneral) {
        ret <- gridExtra::arrangeGrob(genPlot, ret)
      }

      return(ret)
    }
)



##' Summarize the simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{GeneralSimulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{GeneralSimulationsSummary}}
##'
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "GeneralSimulations"),
  def =
    function(object,
             truth,
             target = c(0.2, 0.35),
             ...) {
      ## extract dose grid
      doseGrid <- object@data[[1]]@doseGrid

      ## evaluate true toxicity at doseGrid
      trueTox <- truth(doseGrid, ...)

      ## find dose interval corresponding to target tox interval
      targetDoseInterval <-
        sapply(
          target,
          function(t) {
            ## we have to be careful because it might be
            ## that in the range of the dose grid, no
            ## doses can be found that match the target
            ## interval boundaries!
            ## In that case we want to return NA
            r <- try(
              uniroot(
                f = function(x) {
                  truth(x, ...) - t
                },
                interval =
                  range(doseGrid)
              )$root,
              silent = TRUE
            )
            if (inherits(r, "try-error")) {
              return(NA_real_)
            } else {
              return(r)
            }
          }
        )

      ## what are the levels above target interval?
      xAboveTarget <- which(trueTox > target[2])

      ## proportion of DLTs in a trial:
      if (object@data[[1]]@placebo) {
        if (sum(object@data[[1]]@x == doseGrid[1])) {
          propDLTs <- sapply(
            object@data,
            function(d) {
              tapply(
                d@y,
                factor(d@x == d@doseGrid[1],
                  labels = c("ACTV", "PLCB")
                ),
                mean
              )
            }
          )
        } else {
          propDLTs <- sapply(
            object@data,
            function(d) {
              c("ACTV" = mean(d@y), "PLCB" = NA)
            }
          )
        }
      } else {
        propDLTs <- sapply(
          object@data,
          function(d) {
            mean(d@y)
          }
        )
      }

      ## mean toxicity risk
      if (object@data[[1]]@placebo) {
        meanToxRisk <- sapply(
          object@data,
          function(d) {
            mean(trueTox[d@xLevel[d@xLevel != 1]])
          }
        )
      } else {
        meanToxRisk <- sapply(
          object@data,
          function(d) {
            mean(trueTox[d@xLevel])
          }
        )
      }

      ## doses selected for MTD
      doseSelected <- object@doses

      ## replace NA by 0
      doseSelected[is.na(doseSelected)] <- 0

      ## dose most often selected as MTD
      doseMostSelected <-
        as.numeric(names(which.max(table(doseSelected))))
      xMostSelected <-
        match_within_tolerance(doseMostSelected,
          table = doseGrid
        )

      ## observed toxicity rate at dose most often selected
      ## Note: this does not seem very useful!
      ## Reason: In case of a fine grid, few patients if any
      ## will have been treated at this dose.
      tmp <-
        sapply(
          object@data,
          function(d) {
            whichAtThisDose <- which(d@x == doseMostSelected)
            nAtThisDose <- length(whichAtThisDose)
            nDLTatThisDose <- sum(d@y[whichAtThisDose])
            return(c(
              nAtThisDose = nAtThisDose,
              nDLTatThisDose = nDLTatThisDose
            ))
          }
        )

      obsToxRateAtDoseMostSelected <-
        mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

      ## number of patients overall
      if (object@data[[1]]@placebo) {
        nObs <- sapply(
          object@data,
          function(x) {
            data.frame(
              n.ACTV = sum(x@xLevel != 1L),
              n.PLCB = sum(x@xLevel == 1L)
            )
          }
        )
        nObs <- matrix(unlist(nObs), dim(nObs))
      } else {
        nObs <- sapply(
          object@data,
          slot,
          "nObs"
        )
      }


      ## number of patients treated above target tox interval
      nAboveTarget <- sapply(
        object@data,
        function(d) {
          sum(d@xLevel %in% xAboveTarget)
        }
      )

      ## Proportion of trials selecting target MTD
      toxAtDoses <- truth(doseSelected, ...)
      propAtTarget <- mean((toxAtDoses > target[1]) &
        (toxAtDoses < target[2]))

      ## give back an object of class GeneralSimulationsSummary,
      ## for which we then define a print / plot method
      ret <-
        .GeneralSimulationsSummary(
          target = target,
          target_dose_interval = targetDoseInterval,
          nsim = length(object@data),
          prop_dlts = propDLTs,
          mean_tox_risk = meanToxRisk,
          dose_selected = doseSelected,
          dose_most_selected = doseMostSelected,
          obs_tox_rate_at_dose_most_selected = obsToxRateAtDoseMostSelected,
          n_obs = nObs,
          n_above_target = nAboveTarget,
          tox_at_doses_selected = toxAtDoses,
          prop_at_target = propAtTarget,
          dose_grid = doseGrid,
          placebo = object@data[[1]]@placebo
        )
      return(ret)
    }
)


##' Summarize the model-based design simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{Simulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{SimulationsSummary}}
##'
##' @example examples/Simulations-method-summary.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "Simulations"),
  def =
    function(object,
             truth,
             target = c(0.2, 0.35),
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        truth = truth,
        target = target,
        ...
      )

      doseGrid <- object@data[[1]]@doseGrid

      ## dose level most often selected as MTD
      xMostSelected <-
        match_within_tolerance(start@dose_most_selected,
          table = doseGrid
        )

      ## fitted toxicity rate at dose most often selected
      fitAtDoseMostSelected <-
        sapply(
          object@fit,
          function(f) {
            f$middle[xMostSelected]
          }
        )

      ## mean fitted toxicity (average, lower and upper quantiles)
      ## at each dose level
      ## (this is required for plotting)
      meanFitMatrix <- sapply(
        object@fit,
        "[[",
        "middle"
      )
      meanFit <- list(
        truth =
          truth(doseGrid, ...),
        average =
          rowMeans(meanFitMatrix),
        lower =
          apply(
            meanFitMatrix,
            1L,
            quantile,
            0.025
          ),
        upper =
          apply(
            meanFitMatrix,
            1L,
            quantile,
            0.975
          )
      )

      ## give back an object of class SimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .SimulationsSummary(
        start,
        stop_report = object@stop_report,
        additional_stats = object@additional_stats,
        fit_at_dose_most_selected = fitAtDoseMostSelected,
        mean_fit = meanFit
      )

      return(ret)
    }
)

##' Summarize the dual-endpoint design simulations, relative to given true
##' dose-toxicity and dose-biomarker curves
##'
##' @param object the \code{\linkS4class{DualSimulations}} object we want to
##' summarize
##' @param trueTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity.
##' @param trueBiomarker a function which takes as input a dose (vector) and
##' returns the true biomarker level (vector).
##' @param target the target toxicity interval (default: 20-35%) used for the
##' computations
##' @param \dots Additional arguments can be supplied here for \code{trueTox}
##' and \code{trueBiomarker}
##' @return an object of class \code{\linkS4class{DualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summary-DualSimulations.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "DualSimulations"),
  def =
    function(object,
             trueTox,
             trueBiomarker,
             target = c(0.2, 0.35),
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        truth = trueTox,
        target = target,
        ...
      )

      doseGrid <- object@data[[1]]@doseGrid

      ## dose level most often selected as MTD
      xMostSelected <-
        match_within_tolerance(start@dose_most_selected,
          table = doseGrid
        )

      ## fitted biomarker level at dose most often selected
      biomarkerFitAtDoseMostSelected <-
        sapply(
          object@fit_biomarker,
          function(f) {
            f$middleBiomarker[xMostSelected]
          }
        )

      ## mean fitted biomarker curve (average, lower and upper quantiles)
      ## at each dose level
      ## (this is required for plotting)
      meanBiomarkerFitMatrix <- sapply(
        object@fit_biomarker,
        "[[",
        "middleBiomarker"
      )
      meanBiomarkerFit <- list(
        truth =
          trueBiomarker(doseGrid, ...),
        average =
          rowMeans(meanBiomarkerFitMatrix),
        lower =
          apply(
            meanBiomarkerFitMatrix,
            1L,
            quantile,
            0.025
          ),
        upper =
          apply(
            meanBiomarkerFitMatrix,
            1L,
            quantile,
            0.975
          )
      )

      ## give back an object of class DualSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .DualSimulationsSummary(
        start,
        biomarker_fit_at_dose_most_selected = biomarkerFitAtDoseMostSelected,
        mean_biomarker_fit = meanBiomarkerFit
      )

      return(ret)
    }
)

##' A Reference Class to represent sequentially updated reporting objects.
##' @name Report
##' @field object The object from which to report
##' @field df the data frame to which columns are sequentially added
##' @field dfNames the names to which strings are sequentially added
Report <-
  setRefClass("Report",
    fields =
      list(
        object = "ANY",
        df = "data.frame",
        dfNames = "character"
      ),
    methods = list(
      dfSave =
        function(res, name) {
          df <<- cbind(df, res)
          dfNames <<- c(dfNames, name)
          return(res)
        },
      report =
        function(slotName,
                 description,
                 percent = TRUE,
                 digits = 0,
                 quantiles = c(0.1, 0.9),
                 subset = NULL,
                 doSum = FALSE) {
          vals <- slot(object, name = slotName)
          if (!is.null(subset)) {
            vals <- vals[subset, ]
          }
          if (doSum) {
            vals <- apply(vals, 2, sum)
          }
          if (percent) {
            unit <- " %"
            vals <- vals * 100
          } else {
            unit <- ""
          }

          res <- paste(round(mean(vals), digits),
            unit,
            " (",
            paste(
              round(
                quantile(vals,
                  quantiles,
                  na.rm = TRUE
                ),
                digits
              ),
              unit,
              collapse = ", ",
              sep = ""
            ),
            ")",
            sep = ""
          )

          ## print result to the buffer
          cat(
            description, ":",
            "mean",
            dfSave(res, slotName),
            "\n"
          )
        }
    )
  )


##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{GeneralSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "GeneralSimulationsSummary"),
  def =
    function(object) {
      r <- Report$new(
        object = object,
        df =
          as.data.frame(matrix(
            nrow = 1,
            ncol = 0
          )),
        dfNames = character()
      )

      cat(
        "Summary of",
        r$dfSave(object@nsim, "nsim"),
        "simulations\n\n"
      )

      cat(
        "Target toxicity interval was",
        r$dfSave(
          paste(round(object@target * 100),
            collapse = ", "
          ),
          "target"
        ),
        "%\n"
      )
      cat(
        "Target dose interval corresponding to this was",
        r$dfSave(
          paste(round(object@target_dose_interval, 1),
            collapse = ", "
          ),
          "target_dose_interval"
        ),
        "\n"
      )
      cat(
        "Intervals are corresponding to",
        "10 and 90 % quantiles\n\n"
      )

      if (object@placebo) {
        r$report("n_obs",
          "Number of patients on placebo",
          percent = FALSE,
          subset = 2
        )
        r$report("n_obs",
          "Number of patients on active",
          percent = FALSE,
          subset = 1
        )
        r$report("n_obs",
          "Number of patients overall",
          percent = FALSE,
          doSum = TRUE
        )
      } else {
        r$report("n_obs",
          "Number of patients overall",
          percent = FALSE
        )
      }
      r$report("n_above_target",
        "Number of patients treated above target tox interval",
        percent = FALSE
      )

      if (object@placebo) {
        r$report("prop_dlts",
          "Proportions of DLTs in the trials for patients on placebo",
          subset = 2
        )
        r$report("prop_dlts",
          "Proportions of DLTs in the trials for patients on active",
          subset = 1
        )
      } else {
        r$report(
          "prop_dlts",
          "Proportions of DLTs in the trials"
        )
      }
      r$report(
        "mean_tox_risk",
        "Mean toxicity risks for the patients on active"
      )
      r$report("dose_selected",
        "Doses selected as MTD",
        percent = FALSE, digits = 1
      )
      r$report(
        "tox_at_doses_selected",
        "True toxicity at doses selected"
      )
      cat(
        "Proportion of trials selecting target MTD:",
        r$dfSave(
          object@prop_at_target * 100,
          "prop_at_target"
        ),
        "%\n"
      )
      cat(
        "Dose most often selected as MTD:",
        r$dfSave(
          object@dose_most_selected,
          "dose_most_selected"
        ),
        "\n"
      )
      cat(
        "Observed toxicity rate at dose most often selected:",
        r$dfSave(
          round(object@obs_tox_rate_at_dose_most_selected * 100),
          "obs_tox_rate_at_dose_most_selected"
        ),
        "%\n"
      )

      ## finally assign names to the df
      ## and return it invisibly
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)

##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{SimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-show-SimulationsSummary.R
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "SimulationsSummary"),
  def =
    function(object) {
      ## call the parent method
      df <- callNextMethod(object)
      dfNames <- names(df)

      ## start report object
      r <- Report$new(
        object = object,
        df = df,
        dfNames = dfNames
      )


      ## add one reporting line
      r$report(
        "fit_at_dose_most_selected",
        "Fitted toxicity rate at dose most often selected"
      )

      # Report results of additional statistics summary

      if (length(unlist(object@additional_stats)) > 0) {
        param_names <- h_summarize_add_stats(stats_list = object@additional_stats)[[1]]
        averages <- h_summarize_add_stats(stats_list = object@additional_stats)[[2]]

        for (i in seq_along(param_names)) {
          cat(param_names[i], ":", round(averages[[i]], 2), "\n")
        }
      }


      # Report individual stopping rules with non-<NA> labels.

      stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

      if (length(stop_pct_to_print) > 0) {
        cat(
          "Stop reason triggered:\n",
          paste(names(stop_pct_to_print), ": ", round(stop_pct_to_print, 2), "%\n")
        )
      }

      ## and return the updated information
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)

##' Show the summary of the dual-endpoint simulations
##'
##' @param object the \code{\linkS4class{DualSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-show-DualSimulationsSummary.R
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "DualSimulationsSummary"),
  def =
    function(object) {
      ## call the parent method
      df <- callNextMethod(object)
      dfNames <- names(df)

      ## start report object
      r <- Report$new(
        object = object,
        df = df,
        dfNames = dfNames
      )

      ## add one reporting line
      r$report("biomarker_fit_at_dose_most_selected",
        "Fitted biomarker level at dose most often selected",
        percent = FALSE,
        digits = 1
      )

      ## and return the updated information
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)


##' Graphical display of the general simulation summary
##'
##' This plot method can be applied to
##' \code{\linkS4class{GeneralSimulationsSummary}} objects in order to
##' summarize them graphically. Possible \code{type}s of plots at the moment
##' are:
##'
##' \describe{
##' \item{nObs}{Distribution of the number of patients in the simulated trials}
##' \item{doseSelected}{Distribution of the final selected doses in the trials.
##' Note that this can include zero entries, meaning that the trial was stopped
##' because all doses in the dose grid appeared too toxic.}
##' \item{propDLTs}{Distribution of the proportion of patients with DLTs in the
##' trials}
##' \item{nAboveTarget}{Distribution of the number of patients treated at doses
##' which are above the target toxicity interval (as specified by the
##' \code{truth} and \code{target} arguments to
##' \code{\link{summary,GeneralSimulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{GeneralSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "GeneralSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLTs",
                 "nAboveTarget"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## distribution of overall sample size
      if (x@placebo) {
        if ("nObs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@n_obs[2, ],
              description = "Number of patients on active in total"
            )
        }
      } else {
        if ("nObs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@n_obs,
              description = "Number of patients in total"
            )
        }
      }

      ## distribution of final MTD estimate
      if ("doseSelected" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@dose_selected,
            description = "MTD estimate"
          )
      }

      ## distribution of proportion of DLTs
      if (x@placebo) {
        if ("propDLTs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@prop_dlts[1, ] * 100,
              description = "Proportion of DLTs [%] on active",
              xaxisround = 1
            )
        }
      } else {
        if ("propDLTs" %in% type) {
          plotList[[plotIndex <- plotIndex + 1L]] <-
            h_barplot_percentages(
              x = x@prop_dlts * 100,
              description = "Proportion of DLTs [%]",
              xaxisround = 1
            )
        }
      }

      ## distribution of number of patients treated at too much tox
      if ("nAboveTarget" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@n_above_target,
            description = "Number of patients above target"
          )
      }

      ## first combine these small plots
      if (length(plotList)) {
        ret <-
          ## if there is only one plot
          if (identical(
            length(plotList),
            1L
          )) {
            ## just use that
            plotList[[1L]]
          } else {
            ## multiple plots in this case
            do.call(
              gridExtra::arrangeGrob,
              plotList
            )
          }
      }

      ## then return
      ret
    }
)


##' Plot summaries of the model-based design simulations
##'
##' Graphical display of the simulation summary
##'
##' This plot method can be applied to \code{\linkS4class{SimulationsSummary}}
##' objects in order to summarize them graphically. Possible \code{type} of
##' plots at the moment are those listed in
##' \code{\link{plot,GeneralSimulationsSummary,missing-method}} plus:
##' \describe{
##' \item{meanFit}{Plot showing the average fitted dose-toxicity curve across
##' the trials, together with 95% credible intervals, and comparison with the
##' assumed truth (as specified by the \code{truth} argument to
##' \code{\link{summary,Simulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{SimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-SimulationsSummary.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "SimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLTs",
                 "nAboveTarget",
                 "meanFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for model-based
      ## designs
      typeReduced <- setdiff(
        type,
        "meanFit"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        ret <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## is the meanFit plot requested?
      if ("meanFit" %in% type) {
        ## which types of lines do we have?
        linetype <- c(
          "True toxicity",
          "Average estimated toxicity",
          "95% interval for estimated toxicity"
        )

        ## create the data frame, with
        ## true tox, average estimated tox, and 95% (lower, upper)
        ## estimated tox (in percentage) stacked below each other
        dat <- data.frame(
          dose =
            rep(x@dose_grid, 4L),
          group =
            rep(1:4, each = length(x@dose_grid)),
          linetype =
            factor(
              rep(linetype[c(1, 2, 3, 3)],
                each = length(x@dose_grid)
              ),
              levels = linetype
            ),
          lines =
            unlist(x@mean_fit) * 100
        )

        ## linetypes for the plot
        lt <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 1,
          "95% interval for estimated toxicity" = 2
        )

        ## colour for the plot
        col <- c(
          "True toxicity" = 1,
          "Average estimated toxicity" = 2,
          "95% interval for estimated toxicity" = 2
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Probability of DLT [%]")

        ## add this plot to the bottom
        ret <-
          if (moreFromGeneral) {
            gridExtra::arrangeGrob(ret, thisPlot)
          } else {
            thisPlot
          }
      }

      ## then finally plot everything
      ret
    }
)


##' Plot summaries of the dual-endpoint design simulations
##'
##' This plot method can be applied to \code{\linkS4class{DualSimulationsSummary}}
##' objects in order to summarize them graphically. Possible \code{type} of
##' plots at the moment are those listed in
##' \code{\link{plot,SimulationsSummary,missing-method}} plus:
##' \describe{
##' \item{meanBiomarkerFit}{Plot showing the average fitted dose-biomarker curve across
##' the trials, together with 95% credible intervals, and comparison with the
##' assumed truth (as specified by the \code{trueBiomarker} argument to
##' \code{\link{summary,DualSimulations-method}})}
##' }
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{DualSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plot-DualSimulationsSummary.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "DualSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLTs",
                 "nAboveTarget",
                 "meanFit",
                 "meanBiomarkerFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for dual-endpoint
      ## designs
      typeReduced <- setdiff(
        type,
        "meanBiomarkerFit"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        ret <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## is the meanBiomarkerFit plot requested?
      if ("meanBiomarkerFit" %in% type) {
        ## which types of lines do we have?
        linetype <- c(
          "True biomarker",
          "Average estimated biomarker",
          "95% interval for estimated biomarker"
        )

        ## create the data frame, with
        ## true biomarker, average estimated biomarker, and 95% (lower, upper)
        ## estimated biomarker stacked below each other
        dat <- data.frame(
          dose =
            rep(x@dose_grid, 4L),
          group =
            rep(1:4, each = length(x@dose_grid)),
          linetype =
            factor(
              rep(linetype[c(1, 2, 3, 3)],
                each = length(x@dose_grid)
              ),
              levels = linetype
            ),
          lines =
            unlist(x@mean_biomarker_fit)
        )

        ## linetypes for the plot
        lt <- c(
          "True biomarker" = 1,
          "Average estimated biomarker" = 1,
          "95% interval for estimated biomarker" = 2
        )

        ## colour for the plot
        col <- c(
          "True biomarker" = 1,
          "Average estimated biomarker" = 2,
          "95% interval for estimated biomarker" = 2
        )

        ## now create and save the plot
        thisPlot <- ggplot() +
          geom_line(
            aes(
              x = dose,
              y = lines,
              group = group,
              linetype = linetype,
              col = linetype
            ),
            data = dat
          )

        thisPlot <- thisPlot +
          scale_linetype_manual(values = lt) +
          scale_colour_manual(values = col) +
          xlab("Dose level") +
          ylab("Biomarker level")

        ## add this plot to the bottom
        ret <-
          if (moreFromGeneral) {
            gridExtra::arrangeGrob(ret, thisPlot, heights = c(2 / 3, 1 / 3))
          } else {
            thisPlot
          }
      }

      ## then finally plot everything
      ret
    }
)


## --------------------------------------------------------------------------------------------------------
##' Summarize the simulations, relative to a given truth
##'
##' @param object the \code{\linkS4class{PseudoSimulations}} object we want to
##' summarize
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity
##' @param targetEndOfTrial the target probability of DLE wanted to achieve at the end of a trial
##' @param targetDuringTrial the target probability of DLE wanted to achieve during a trial
##'
##' @param \dots Additional arguments can be supplied here for \code{truth}
##' @return an object of class \code{\linkS4class{PseudoSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMsingle.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "PseudoSimulations"),
  def =
    function(object,
             truth,
             targetEndOfTrial = 0.3,
             targetDuringTrial = 0.35,
             ...) {
      ## extract dose grid
      doseGrid <- object@data[[1]]@doseGrid

      ## evaluate true DLE at doseGrid
      trueDLE <- truth(doseGrid)

      ## Inverse function of the truth function
      inverse <- function(f, lower = -100, upper = 100) {
        function(y) uniroot((function(x) f(x) - y), lower = lower, upper = upper)[1]
      }

      ## Function to obtain corresponsing dose level given target prob
      TD <- inverse(truth, 0, max(doseGrid))

      ## Find the dose corresponding to the target dose during trial
      targetDoseEndOfTrial <- as.numeric(TD(targetEndOfTrial))


      ## Find the dose corresponding to the target does end of trial
      targetDoseDuringTrial <- as.numeric(TD(targetDuringTrial))

      ## Find the dose at doseGrid corresponding to the above two quantities
      targetDoseEndOfTrialAtDoseGrid <- doseGrid[max(which(targetDoseEndOfTrial - doseGrid >= 0))]
      targetDoseDuringTrialAtDoseGrid <- doseGrid[max(which(targetDoseDuringTrial - doseGrid >= 0))]

      ## A summary for all TDtargetEndOfTrial dose obtained
      TDEOTSummary <- summary(object@final_td_target_end_of_trial_estimates)

      FinalDoseRecSummary <- TDEOTSummary

      ratioTDEOTSummary <- summary(object@final_tdeot_ratios)
      FinalRatioSummary <- ratioTDEOTSummary


      ## A summary for all TDtargetDuringTrial dose obtained
      TDDTSummary <- summary(object@final_td_target_during_trial_estimates)
      ## what are the levels above target End of Trial?
      xAboveTargetEndOfTrial <- which(trueDLE > targetEndOfTrial)

      ## what are the levels above target During Trial?
      xAboveTargetDuringTrial <- which(trueDLE > targetDuringTrial)


      ## proportion of DLEs in this trial
      propDLE <- sapply(
        object@data,
        function(d) {
          mean(d@y)
        }
      )
      ### mean toxicity risk
      meanToxRisk <- sapply(
        object@data,
        function(d) {
          mean(trueDLE[d@xLevel])
        }
      )

      ## doses selected for MTD
      doseSelected <- object@doses

      ## replace NA by 0
      doseSelected[is.na(doseSelected)] <- 0

      ## dose most often selected as MTD
      doseMostSelected <-
        as.numeric(names(which.max(table(doseSelected))))

      # doseRec <- doseMostSelected

      xMostSelected <-
        match_within_tolerance(doseMostSelected,
          table = doseGrid
        )

      ## observed toxicity rate at dose most often selected
      ## Note: this does not seem very useful!
      ## Reason: In case of a fine grid, few patients if any
      ## will have been treated at this dose.
      tmp <-
        sapply(
          object@data,
          function(d) {
            whichAtThisDose <- which(d@x == doseMostSelected)
            nAtThisDose <- length(whichAtThisDose)
            nDLTatThisDose <- sum(d@y[whichAtThisDose])
            return(c(
              nAtThisDose = nAtThisDose,
              nDLTatThisDose = nDLTatThisDose
            ))
          }
        )

      obsToxRateAtDoseMostSelected <-
        mean(tmp["nDLTatThisDose", ]) / mean(tmp["nAtThisDose", ])

      ## number of patients overall
      nObs <- sapply(
        object@data,
        slot,
        "nObs"
      )

      ## number of patients treated above target End of trial
      nAboveTargetEndOfTrial <- sapply(
        object@data,
        function(d) {
          sum(d@xLevel %in% xAboveTargetEndOfTrial)
        }
      )

      ## number of patients treated above target During trial
      nAboveTargetDuringTrial <- sapply(
        object@data,
        function(d) {
          sum(d@xLevel %in% xAboveTargetDuringTrial)
        }
      )

      toxAtDoses <- truth(doseSelected)


      ## Proportion of trials selecting target TDEndOfTrial and TDDuringTrial
      nsim <- length(object@data)

      propAtTargetEndOfTrial <- (length(which(object@doses == targetDoseEndOfTrialAtDoseGrid))) / nsim
      propAtTargetDuringTrial <- (length(which(object@doses == targetDoseDuringTrialAtDoseGrid))) / nsim

      RecDoseSummary <- TDEOTSummary

      ## fitted probDLE at dose most often selected
      ## find names in the fit list (check it is with or without samples)
      FitNames <- sapply(object@fit, names)


      if ("probDLE" %in% FitNames) {
        fitAtDoseMostSelected <- sapply(
          object@fit,
          function(f) {
            f$probDLE[xMostSelected]
          }
        )
        meanFitMatrix <- sapply(
          object@fit,
          "[[",
          "probDLE"
        )

        meanFit <- list(
          truth =
            truth(doseGrid),
          average = rowMeans(meanFitMatrix)
        )
      } else {
        ## fitted toxicity rate at dose most often selected
        fitAtDoseMostSelected <-
          sapply(
            object@fit,
            function(f) {
              f$middle[xMostSelected]
            }
          )

        ## mean fitted toxicity (average, lower and upper quantiles)
        ## at each dose level
        ## (this is required for plotting)
        meanFitMatrix <- sapply(
          object@fit,
          "[[",
          "middle"
        )
        meanFit <- list(
          truth =
            truth(doseGrid),
          average =
            rowMeans(meanFitMatrix),
          lower =
            apply(
              meanFitMatrix,
              1L,
              quantile,
              0.025
            ),
          upper =
            apply(
              meanFitMatrix,
              1L,
              quantile,
              0.975
            )
        )
      }

      ## give back an object of class GeneralSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .PseudoSimulationsSummary(
        targetEndOfTrial = targetEndOfTrial,
        targetDoseEndOfTrial = targetDoseEndOfTrial,
        targetDuringTrial = targetDuringTrial,
        targetDoseDuringTrial = targetDoseDuringTrial,
        targetDoseEndOfTrialAtDoseGrid = targetDoseEndOfTrialAtDoseGrid,
        targetDoseDuringTrialAtDoseGrid = targetDoseDuringTrialAtDoseGrid,
        TDEOTSummary = TDEOTSummary,
        TDDTSummary = TDDTSummary,
        FinalDoseRecSummary = FinalDoseRecSummary,
        ratioTDEOTSummary = ratioTDEOTSummary,
        FinalRatioSummary = FinalRatioSummary,
        nsim = length(object@data),
        propDLE = propDLE,
        meanToxRisk = meanToxRisk,
        doseSelected = doseSelected,
        doseMostSelected = doseMostSelected,
        # doseRec=doseRec,
        obsToxRateAtDoseMostSelected = obsToxRateAtDoseMostSelected,
        nObs = nObs,
        nAboveTargetEndOfTrial = nAboveTargetEndOfTrial,
        nAboveTargetDuringTrial = nAboveTargetDuringTrial,
        toxAtDosesSelected = toxAtDoses,
        propAtTargetEndOfTrial = propAtTargetEndOfTrial,
        propAtTargetDuringTrial = propAtTargetDuringTrial,
        doseGrid = doseGrid,
        fitAtDoseMostSelected = fitAtDoseMostSelected,
        stop_report = object@stop_report,
        meanFit = meanFit
      )

      return(ret)
    }
)
## ========================================================================================================
##' Show the summary of the simulations
##'
##' @param object the \code{\linkS4class{PseudoSimulationsSummary}} object we want
##' to print
##' @return invisibly returns a data frame of the results with one row and
##' appropriate column names
##'
##' @example examples/Simulations-method-showSIMsingle.R
##' @export
##' @keywords methods

setMethod("show",
  signature =
    signature(object = "PseudoSimulationsSummary"),
  def =
    function(object) {
      r <- Report$new(
        object = object,
        df =
          as.data.frame(matrix(
            nrow = 1,
            ncol = 0
          )),
        dfNames = character()
      )
      cat(
        "Summary of",
        r$dfSave(object@nsim, "nsim"),
        "simulations\n\n"
      )

      cat(
        "Target probability of DLE p(DLE) used at the end of a trial was",
        r$dfSave(
          object@targetEndOfTrial * 100,
          "targetEndOfTrial"
        ), "%\n"
      )

      cat(
        "The dose level corresponds to the target p(DLE) used at the end of a trial, TDEOT, was",
        r$dfSave(
          object@targetDoseEndOfTrial,
          "targetDoseEndOfTrial"
        ), "\n"
      )
      cat(
        "TDEOT at dose Grid was",
        r$dfSave(
          object@targetDoseEndOfTrialAtDoseGrid,
          "targetDoseEndOfTrialAtDoseGrid"
        ), "\n"
      )

      cat(
        "Target p(DLE) used during a trial was",
        r$dfSave(
          object@targetDuringTrial * 100,
          "targetDuringTrial"
        ), "%\n"
      )

      cat(
        "The dose level corresponds to the target p(DLE) used during a trial, TDDT, was",
        r$dfSave(
          object@targetDoseDuringTrial,
          "targetDoseDuringTrial"
        ), "\n"
      )

      cat(
        "TDDT at dose Grid was",
        r$dfSave(
          object@targetDoseDuringTrialAtDoseGrid,
          "targetDoseDuringTrialAtDoseGrid"
        ), "\n"
      )

      r$report("nObs",
        "Number of patients overall",
        percent = FALSE
      )
      r$report("nAboveTargetEndOfTrial",
        "Number of patients treated above the target p(DLE) used at the end of a trial",
        percent = FALSE
      )

      r$report("nAboveTargetDuringTrial",
        "Number of patients treated above the target p(DLE) used during a trial",
        percent = FALSE
      )

      r$report(
        "propDLE",
        "Proportions of observed DLT in the trials"
      )
      r$report(
        "meanToxRisk",
        "Mean toxicity risks for the patients"
      )
      r$report("doseSelected",
        "Doses selected as TDEOT",
        percent = FALSE, digits = 1
      )
      # r$report("doseRec",
      #         "Doses to recommend to subsequent study",
      #         percent=FALSE, digits=1)

      r$report(
        "toxAtDosesSelected",
        "True toxicity at TDEOT"
      )

      cat(
        "Proportion of trials selecting the TDEOT:",
        r$dfSave(
          object@propAtTargetEndOfTrial * 100,
          "percentAtTarget"
        ),
        "%\n"
      )


      cat(
        "Proportion of trials selecting the TDDT:",
        r$dfSave(
          object@propAtTargetDuringTrial * 100,
          "percentAtTarget"
        ),
        "%\n"
      )

      cat(
        "Dose most often selected as TDEOT:",
        r$dfSave(
          object@doseMostSelected,
          "doseMostSelected"
        ),
        "\n"
      )
      cat(
        "Observed toxicity rate at dose most often selected:",
        r$dfSave(
          round(object@obsToxRateAtDoseMostSelected * 100),
          "obsToxRateAtDoseMostSelected"
        ),
        "%\n"
      )
      r$report(
        "fitAtDoseMostSelected",
        "Fitted probabilities of DLE at dose most often selected"
      )

      TDEOTSum <- object@TDEOTSummary

      r$dfSave(as.numeric(TDEOTSum[1]), "TDEOTMin")
      r$dfSave(as.numeric(TDEOTSum[2]), "TDEOTlower")
      r$dfSave(as.numeric(TDEOTSum[3]), "TDEOTMedian")
      r$dfSave(as.numeric(TDEOTSum[4]), "TDEOTMean")
      r$dfSave(as.numeric(TDEOTSum[5]), "TDEOTUpper")
      r$dfSave(as.numeric(TDEOTSum[6]), "TDEOTMax")

      cat(
        "The summary table of the final TDEOT across all simulations\n",
        capture.output(TDEOTSum)[1], "\n",
        capture.output(TDEOTSum)[2], "\n"
      )

      ratioTDEOTSum <- object@ratioTDEOTSummary

      r$dfSave(as.numeric(ratioTDEOTSum[1]), "ratioTDEOTMin")
      r$dfSave(as.numeric(ratioTDEOTSum[2]), "ratioTDEOTlower")
      r$dfSave(as.numeric(ratioTDEOTSum[3]), "ratioTDEOTMedian")
      r$dfSave(as.numeric(ratioTDEOTSum[4]), "ratioTDEOTMean")
      r$dfSave(as.numeric(ratioTDEOTSum[5]), "ratioTDEOTUpper")
      r$dfSave(as.numeric(ratioTDEOTSum[6]), "ratioTDEOTMax")

      cat(
        "The summary table of the final ratios of the TDEOT across all simulations\n",
        capture.output(ratioTDEOTSum)[1], "\n",
        capture.output(ratioTDEOTSum)[2], "\n"
      )

      TDDTSum <- object@TDDTSummary

      r$dfSave(as.numeric(TDDTSum[1]), "TDDTMin")
      r$dfSave(as.numeric(TDDTSum[2]), "TDDTlower")
      r$dfSave(as.numeric(TDDTSum[3]), "TDDTMedian")
      r$dfSave(as.numeric(TDDTSum[4]), "TDDTMean")
      r$dfSave(as.numeric(TDDTSum[5]), "TDDTUpper")
      r$dfSave(as.numeric(TDDTSum[6]), "TDDTMax")

      cat(
        "The summary table of the final TDDT across all simulations\n",
        capture.output(TDDTSum)[1], "\n",
        capture.output(TDDTSum)[2], "\n"
      )

      FinalDoseRecSum <- object@FinalDoseRecSummary

      r$dfSave(as.numeric(FinalDoseRecSum[1]), "FinalDoseRecMin")
      r$dfSave(as.numeric(FinalDoseRecSum[2]), "FinalDoseReclower")
      r$dfSave(as.numeric(FinalDoseRecSum[3]), "FinalDoseRecMedian")
      r$dfSave(as.numeric(FinalDoseRecSum[4]), "FinalDoseRecMean")
      r$dfSave(as.numeric(FinalDoseRecSum[5]), "FinalDoseRecUpper")
      r$dfSave(as.numeric(FinalDoseRecSum[6]), "FinalDoseRecMax")

      cat(
        "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
        capture.output(FinalDoseRecSum)[1], "\n",
        capture.output(FinalDoseRecSum)[2], "\n"
      )


      FinalratioSum <- object@FinalRatioSummary

      r$dfSave(as.numeric(FinalratioSum[1]), "FinalratioMin")
      r$dfSave(as.numeric(FinalratioSum[2]), "Finalratiolower")
      r$dfSave(as.numeric(FinalratioSum[3]), "FinalratioMedian")
      r$dfSave(as.numeric(FinalratioSum[4]), "FinalratioMean")
      r$dfSave(as.numeric(FinalratioSum[5]), "FinalratioUpper")
      r$dfSave(as.numeric(FinalratioSum[6]), "FinalratioMax")

      cat(
        "The summary table of the final ratios of the optimal dose for stopping across
                  all simulations\n",
        capture.output(FinalratioSum)[1], "\n",
        capture.output(FinalratioSum)[2], "\n\n"
      )

      # Report individual stopping rules with non-<NA> labels.

      stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

      if (length(stop_pct_to_print) > 0) {
        cat(
          "Stop reason triggered:\n",
          paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
        )
      }

      ## finally assign names to the df
      ## and return it invisibly
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)
## -------------------------------------------------------------------------------------------
##' Plot summaries of the pseudo simulations
##'
##' Graphical display of the simulation summary
##'
##' This plot method can be applied to \code{\linkS4class{PseudoSimulationsSummary}}
##' objects in order to summarize them graphically. This can be used when only DLE responses are involved
##' in the simulations. This also applied to results with or without samples generated during the simulations
##'
##' @param x the \code{\linkS4class{PseudoSimulationsSummary}} object we want
##' to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSUMsingle.R
##' @export
##' @keywords methods
##'

setMethod("plot",
  signature =
    signature(
      x = "PseudoSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLE",
                 "nAboveTargetEndOfTrial",
                 "meanFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## distribution of overall sample size
      if ("nObs" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@nObs,
            description = "Number of patients in total"
          )
      }

      ## distribution of final MTD estimate
      if ("doseSelected" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@doseSelected,
            description = "MTD estimate"
          )
      }

      ## distribution of proportion of DLTs
      if ("propDLE" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@propDLE * 100,
            description = "Proportion of DLE [%]",
            xaxisround = 1
          )
      }

      ## distribution of number of patients treated at too much tox
      if ("nAboveTargetEndOfTrial" %in% type) {
        plotList[[plotIndex <- plotIndex + 1L]] <-
          h_barplot_percentages(
            x = x@nAboveTargetEndOfTrial,
            description = "Number of patients above target"
          )
      }


      ## first combine these small plots
      if (length(plotList)) {
        ret <-
          ## if there is only one plot
          if (identical(
            length(plotList),
            1L
          )) {
            ## just use that
            plotList[[1L]]
          } else {
            ## multiple plots in this case
            do.call(
              gridExtra::arrangeGrob,
              plotList
            )
          }
      }

      ## the meanFit plot

      if ("meanFit" %in% type) { ## Find if DLE samples are generated in the simulations
        ## by checking if there the lower limits of the 95% Credibility
        ## interval are calculated
        if (!is.null(x@meanFit$lower)) {
          ## which types of lines do we have?
          linetype <- c(
            "True toxicity",
            "Average estimated toxicity",
            "95% interval for estimated toxicity"
          )
          ## create the data frame, with
          ## true tox, average estimated tox, and 95% (lower, upper)
          ## estimated tox (in percentage) stacked below each other
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 4L),
            group =
              rep(1:4, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2, 3, 3)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanFit) * 100
          )

          ## linetypes for the plot
          lt <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 1,
            "95% interval for estimated toxicity" = 2
          )

          ## colour for the plot
          col <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 2,
            "95% interval for estimated toxicity" = 2
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Probability of DLE [%]")
        } else {
          ## which types of lines do we have?
          linetype <- c(
            "True toxicity",
            "Average estimated toxicity"
          )

          ## create the data frame, with
          ## true tox, average estimated tox
          ## estimated tox (in percentage) stacked below each other
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 2L),
            group =
              rep(1:2, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanFit) * 100
          )

          ## linetypes for the plot
          lt <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 1
          )

          ## colour for the plot
          col <- c(
            "True toxicity" = 1,
            "Average estimated toxicity" = 2
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Probability of DLE [%]")
        }
      }


      ## then add this plot at the bottom
      ret <- gridExtra::arrangeGrob(ret, thisPlot)
      ret
    }
)
## --------------------------------------------------------------------------------------
##' Plot simulations
##'
##' Summarize the simulations with plots
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} \item{sigma2}{The variance of the efficacy responses}}
##' You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMDual.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "PseudoDualSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried",
                 "sigma2"
               ),
             ...) {
      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for
      ## dual-endpoint simulation results
      typeReduced <- setdiff(
        type,
        "sigma2"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## now to the specific dual-endpoint plots:

      ## Efficacy variance estimates boxplot
      if ("sigma2" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@sigma2est), geom = "boxplot",
            xlab = "", ylab = "Efficacy variance estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }


      ## then finally plot everything
      if (identical(
        length(plotList),
        0L
      )) {
        return(genPlot)
      } else if (identical(
        length(plotList),
        1L
      )) {
        ret <- plotList[[1L]]
      } else {
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
      }

      if (moreFromGeneral) {
        ret <- gridExtra::arrangeGrob(genPlot, ret, heights = c(2 / 3, 1 / 3))
      }

      return(ret)
    }
)
## ---------------------------------------------------------------------------------
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualFlexiSimulations}}
##' objects in order to summarize them graphically. Possible \code{type}s of
##' plots at the moment are: \describe{ \item{trajectory}{Summary of the
##' trajectory of the simulated trials} \item{dosesTried}{Average proportions of
##' the doses tested in patients} \item{sigma2}{The variance of the efficacy responses}
##' \item{sigma2betaW}{The variance of the random walk model}}
##' You can specify one or both of these in the
##' \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualFlexiSimulations}} object we want
##' to plot from
##' @param y missing
##' @param type the type of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 ggplot geom_step geom_bar aes xlab ylab
##' scale_linetype_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSIMDualFlexi.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "PseudoDualFlexiSimulations",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "trajectory",
                 "dosesTried",
                 "sigma2",
                 "sigma2betaW"
               ),
             ...) {
      ## start the plot list
      plotList <- list()
      plotIndex <- 0L

      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for
      ## dual-endpoint simulation results
      typeReduced <- setdiff(type, "sigma2betaW")

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        genPlot <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## now to the specific dual-endpoint plots:
      ## random walk model variance estimates boxplot

      if ("sigma2betaW" %in% type) {
        ## save the plot
        plotList[[plotIndex <- plotIndex + 1L]] <-
          qplot(factor(0),
            y = y, data = data.frame(y = x@sigma2betaWest), geom = "boxplot",
            xlab = "", ylab = "Random walk model variance estimates"
          ) +
          coord_flip() + scale_x_discrete(breaks = NULL)
      }

      ## then finally plot everything
      if (identical(
        length(plotList),
        0L
      )) {
        return(genPlot)
      } else if (identical(
        length(plotList),
        1L
      )) {
        ret <- plotList[[1L]]
      } else {
        ret <- do.call(
          gridExtra::arrangeGrob,
          plotList
        )
      }

      if (moreFromGeneral) {
        ret <- gridExtra::arrangeGrob(genPlot, ret, heights = c(2 / 3, 1 / 3))
      }

      return(ret)
    }
)

## -----------------------------------------------------------------------------------------
##' Summary for Pseudo Dual responses simulations, relative to a given pseudo DLE and efficacy model
##' (except the EffFlexi class model)
##'
##' @param object the \code{\linkS4class{PseudoDualSimulations}} object we want to summarize
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability (vector)
##' of DLE
##' @param trueEff a function which takes as input a dose (vector) and returns the mean efficacy value(s) (vector).
##' @param targetEndOfTrial the target probability of DLE that are used at the end of a trial. Default at 0.3.
##' @param targetDuringTrial the target probability of DLE that are used during the trial. Default at 0.35.
##' @param \dots Additional arguments can be supplied here for \code{trueDLE} and \code{trueEff}
##' @return an object of class \code{\linkS4class{PseudoDualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMDual.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "PseudoDualSimulations"),
  def =
    function(object,
             trueDLE,
             trueEff,
             targetEndOfTrial = 0.3,
             targetDuringTrial = 0.35,
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        truth = trueDLE,
        targetEndOfTrial = targetEndOfTrial,
        targetDuringTrial = targetDuringTrial,
        ...
      )
      doseGrid <- object@data[[1]]@doseGrid

      ## ## dose level most often selected as MTD (TDtargetEnd of Trial)
      xMostSelected <-
        match_within_tolerance(start@doseMostSelected,
          table = doseGrid
        )

      ## check if true Eff is a function
      ## check if special case applies
      isTrueEffFx <- is.function(trueEff)

      TDtargetEndOfTrial <- start@targetDoseEndOfTrial


      if (isTrueEffFx) {
        negtrueGainfn <- function(dose) {
          return(-(trueEff(dose)) / (1 + (trueDLE(dose) / (1 - trueDLE(dose)))))
        }
        Gstar <- optim(exp(1), negtrueGainfn, method = "BFGS")$par
        maxGainValue <- -(optim(exp(1), negtrueGainfn, method = "BFGS")$value)
        GstarAtDoseGrid <- doseGrid[max(which(Gstar - doseGrid >= 0))]
      } else {
        trueGain <- (trueEff) / (1 + (trueDLE(doseGrid) / (1 - trueDLE(doseGrid))))
        maxGainValue <- max(trueGain)
        Gstar <- doseGrid[which.max(trueGain)]
        GstarAtDoseGrid <- Gstar
      }

      ## A summary for all final Gstar obtained
      GstarSummary <- summary(object@FinalGstarEstimates)
      ratioGstarSummary <- summary(object@FinalGstarRatios)

      FinalDoseRecSummary <- summary(object@FinalOptimalDose)
      FinalRatioSummary <- summary(object@final_ratios)



      ## find names in the fit efficacy list (check it is with or without samples)
      FitNames <- sapply(object@fitEff, names)
      if ("ExpEff" %in% FitNames) {
        ## fitted efficacy level at dose most often selected
        EffFitAtDoseMostSelected <- sapply(
          object@fitEff,
          function(f) {
            f$ExpEff[xMostSelected]
          }
        )
        meanEffFitMatrix <- sapply(
          object@fitEff,
          "[[",
          "ExpEff"
        )

        meanEffFit <- list(
          truth =
            trueEff(doseGrid),
          average = rowMeans(meanEffFitMatrix)
        )
      } else { ## fitted efficacy level at dose most often selected
        EffFitAtDoseMostSelected <-
          sapply(
            object@fitEff,
            function(f) {
              f$middle[xMostSelected]
            }
          )

        ## mean fitted  curve (average, lower and upper quantiles)
        ## at each dose level
        ## (this is required for plotting)
        meanEffFitMatrix <- sapply(
          object@fitEff,
          "[[",
          "middle"
        )

        ## check if special case applies

        if (isTrueEffFx) {
          TRUTHeff <- trueEff(doseGrid)
        } else {
          TRUTHeff <- trueEff
        }

        meanEffFit <- list(
          truth =
            TRUTHeff,
          average =
            rowMeans(meanEffFitMatrix),
          lower =
            apply(
              meanEffFitMatrix,
              1L,
              quantile,
              0.025
            ),
          upper =
            apply(
              meanEffFitMatrix,
              1L,
              quantile,
              0.975
            )
        )
      }

      ## give back an object of class PseudoDualSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .PseudoDualSimulationsSummary(
        start,
        targetGstar = Gstar,
        targetGstarAtDoseGrid = GstarAtDoseGrid,
        GstarSummary = GstarSummary,
        ratioGstarSummary = ratioGstarSummary,
        FinalDoseRecSummary = FinalDoseRecSummary,
        FinalRatioSummary = FinalRatioSummary,
        EffFitAtDoseMostSelected = EffFitAtDoseMostSelected,
        meanEffFit = meanEffFit,
        stop_report = object@stop_report
      )

      return(ret)
    }
)
## --------------------------------------------------------------------------------------------------
##' Summary for Pseudo Dual responses simulations given a pseudo DLE model and the Flexible efficacy model.
##'
##' @param object the \code{\linkS4class{PseudoDualFlexiSimulations}} object we want to summarize
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability of DLE (vector)
##' @param trueEff a vector which takes as input the true mean efficacy values at all dose levels (in order)
##' @param targetEndOfTrial the target probability of DLE that are used at the end of a trial. Default at 0.3.
##' @param targetDuringTrial the target probability of DLE that are used during the trial. Default at 0.35.
##' @param \dots Additional arguments can be supplied here for \code{trueDLE} and \code{trueEff}
##' @return an object of class \code{\linkS4class{PseudoDualSimulationsSummary}}
##'
##' @example examples/Simulations-method-summarySIMDualFlexi.R
##' @export
##' @keywords methods
setMethod("summary",
  signature =
    signature(object = "PseudoDualFlexiSimulations"),
  def =
    function(object,
             trueDLE,
             trueEff,
             targetEndOfTrial = 0.3,
             targetDuringTrial = 0.35,
             ...) {
      ## call the parent method
      start <- callNextMethod(
        object = object,
        trueDLE = trueDLE,
        trueEff = trueEff,
        targetEndOfTrial = targetEndOfTrial,
        targetDuringTrial = targetDuringTrial,
        ...
      )


      ## give back an object of class PseudoDualSimulationsSummary,
      ## for which we then define a print / plot method
      ret <- .PseudoDualSimulationsSummary(start)

      return(ret)
    }
)

## ----------------------------------------------------------------------------------------
##' Show the summary of Pseudo Dual simulations summary
##'
##' @param object the \code{\linkS4class{PseudoDualSimulationsSummary}} object we want to print
##' @return invisibly returns a data frame of the results with one row and appropriate column names
##'
##'
##' @example examples/Simulations-method-showSIMDual.R
##' @export
##' @keywords methods
setMethod("show",
  signature =
    signature(object = "PseudoDualSimulationsSummary"),
  def =
    function(object) {
      ## call the parent method
      df <- callNextMethod(object)
      dfNames <- names(df)

      ## start report object
      r <- Report$new(
        object = object,
        df = df,
        dfNames = dfNames
      )

      ## add three reporting lines
      cat(
        "Target Gstar, the dose which gives the maximum gain value was",
        r$dfSave(
          object@targetGstar,
          "targetGstar"
        ), "\n"
      )
      cat(
        "Target Gstar at dose Grid was",
        r$dfSave(
          object@targetGstarAtDoseGrid,
          "targetGstarAtDoseGrid"
        ), "\n"
      )

      GstarSum <- object@GstarSummary

      r$dfSave(as.numeric(GstarSum[1]), "GstarMin")
      r$dfSave(as.numeric(GstarSum[2]), "Gstarlower")
      r$dfSave(as.numeric(GstarSum[3]), "GstarMedian")
      r$dfSave(as.numeric(GstarSum[4]), "GstarMean")
      r$dfSave(as.numeric(GstarSum[5]), "GstarUpper")
      r$dfSave(as.numeric(GstarSum[6]), "GstarMax")

      cat(
        "The summary table of the final Gstar across all simulations\n",
        capture.output(GstarSum)[1], "\n",
        capture.output(GstarSum)[2], "\n"
      )

      ratioGstarSum <- object@ratioGstarSummary

      r$dfSave(as.numeric(ratioGstarSum[1]), "ratioGstarMin")
      r$dfSave(as.numeric(ratioGstarSum[2]), "ratioGstarlower")
      r$dfSave(as.numeric(ratioGstarSum[3]), "ratioGstarMedian")
      r$dfSave(as.numeric(ratioGstarSum[4]), "ratioGstarMean")
      r$dfSave(as.numeric(ratioGstarSum[5]), "ratioGstarUpper")
      r$dfSave(as.numeric(ratioGstarSum[6]), "ratioGstarMax")

      cat(
        "The summary table of the final ratios of the Gstar across all simulations\n",
        capture.output(ratioGstarSum)[1], "\n",
        capture.output(ratioGstarSum)[2], "\n"
      )

      FinalDoseRecSum <- object@FinalDoseRecSummary

      r$dfSave(as.numeric(FinalDoseRecSum[1]), "FinalDoseRecMin")
      r$dfSave(as.numeric(FinalDoseRecSum[2]), "FinalDoseReclower")
      r$dfSave(as.numeric(FinalDoseRecSum[3]), "FinalDoseRecMedian")
      r$dfSave(as.numeric(FinalDoseRecSum[4]), "FinalDoseRecMean")
      r$dfSave(as.numeric(FinalDoseRecSum[5]), "FinalDoseRecUpper")
      r$dfSave(as.numeric(FinalDoseRecSum[6]), "FinalDoseRecMax")

      cat(
        "The summary table of dose levels, the optimal dose\n to recommend for subsequent study across all simulations\n",
        capture.output(FinalDoseRecSum)[1], "\n",
        capture.output(FinalDoseRecSum)[2], "\n"
      )

      FinalratioSum <- object@FinalRatioSummary

      r$dfSave(as.numeric(FinalratioSum[1]), "FinalratioMin")
      r$dfSave(as.numeric(FinalratioSum[2]), "Finalratiolower")
      r$dfSave(as.numeric(FinalratioSum[3]), "FinalratioMedian")
      r$dfSave(as.numeric(FinalratioSum[4]), "FinalratioMean")
      r$dfSave(as.numeric(FinalratioSum[5]), "FinalratioUpper")
      r$dfSave(as.numeric(FinalratioSum[6]), "FinalratioMax")

      cat(
        "The summary table of the final ratios of the optimal dose for stopping across
        all simulations\n",
        capture.output(FinalratioSum)[1], "\n",
        capture.output(FinalratioSum)[2], "\n"
      )


      r$report("EffFitAtDoseMostSelected",
        "Fitted expected efficacy level at dose most often selected",
        percent = FALSE,
        digits = 1
      )

      # Report individual stopping rules with non-<NA> labels.

      stop_pct_to_print <- h_calc_report_label_percentage(object@stop_report)

      if (length(stop_pct_to_print) > 0) {
        cat(
          "Stop reason triggered:\n",
          paste(names(stop_pct_to_print), ": ", stop_pct_to_print, "%\n")
        )
      }


      ## and return the updated information
      names(r$df) <- r$dfNames
      invisible(r$df)
    }
)

## --------------------------------------------------------------------------------------------------
##' Plot the summary of Pseudo Dual Simulations summary
##'
##' This plot method can be applied to \code{\linkS4class{PseudoDualSimulationsSummary}} objects in order
##' to summarize them graphically. Possible \code{type} of plots at the moment are those listed in
##' \code{\link{plot,PseudoSimulationsSummary,missing-method}} plus:
##' \describe{\item{meanEffFit}{Plot showing the fitted dose-efficacy curve. If no samples are involved, only the
##' average fitted dose-efficacy curve across the trials will be plotted. If samples (DLE and efficacy) are involved,
##' the average fitted dose-efficacy curve across the trials, together with the 95% credibility interval; and comparison
##' with the assumed truth (as specified by the \code{trueEff} argument to
##' \code{\link{summary,PseudoDualSimulations-method}})}}
##' You can specify any subset of these in the \code{type} argument.
##'
##' @param x the \code{\linkS4class{PseudoDualSimulationsSummary}} object we want to plot from
##' @param y missing
##' @param type the types of plots you want to obtain.
##' @param \dots not used
##' @return A single \code{\link[ggplot2]{ggplot}} object if a single plot is
##' asked for, otherwise a \code{\link{gridExtra}{gTree}} object.
##'
##' @importFrom ggplot2 geom_histogram ggplot aes xlab ylab geom_line
##' scale_linetype_manual scale_colour_manual
##' @importFrom gridExtra arrangeGrob
##'
##' @example examples/Simulations-method-plotSUMDual.R
##' @export
##' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "PseudoDualSimulationsSummary",
      y = "missing"
    ),
  def =
    function(x,
             y,
             type =
               c(
                 "nObs",
                 "doseSelected",
                 "propDLE",
                 "nAboveTargetEndOfTrial",
                 "meanFit",
                 "meanEffFit"
               ),
             ...) {
      ## which plots should be produced?
      type <- match.arg(type,
        several.ok = TRUE
      )
      stopifnot(length(type) > 0L)

      ## substract the specific plot types for dual-endpoint
      ## designs
      typeReduced <- setdiff(
        type,
        "meanEffFit"
      )

      ## are there more plots from general?
      moreFromGeneral <- (length(typeReduced) > 0)

      ## if so, then produce these plots
      if (moreFromGeneral) {
        ret <- callNextMethod(x = x, y = y, type = typeReduced)
      }

      ## is the meanBiomarkerFit plot requested?
      if ("meanEffFit" %in% type) { ## Find if Effsamples are generated in the simulations
        ## by checking if there the lower limits of the 95% Credibility
        ## interval are calculated
        if (!is.null(x@meanEffFit$lower)) {
          ## which types of lines do we have?
          linetype <- c(
            "True Expected Efficacy",
            "Average estimated expected efficacy",
            "95% interval for estimated expected efficacy"
          )

          ## create the data frame, with
          ## true biomarker, average estimated expected efficacy, and 95% (lower, upper)
          ## estimated biomarker stacked below each other
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 4L),
            group =
              rep(1:4, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2, 3, 3)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanEffFit)
          )

          ## linetypes for the plot
          lt <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 1,
            "95% interval for estimated expected efficacy" = 2
          )

          ## colour for the plot
          col <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 4,
            "95% interval for estimated expected efficacy" = 4
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Expected Efficacy level")
        } else {
          linetype <- c(
            "True Expected Efficacy",
            "Average estimated expected efficacy"
          )

          ## create the data frame, with
          ## true biomarker, average estimated expected efficacy
          dat <- data.frame(
            dose =
              rep(x@doseGrid, 2L),
            group =
              rep(1:2, each = length(x@doseGrid)),
            linetype =
              factor(
                rep(linetype[c(1, 2)],
                  each = length(x@doseGrid)
                ),
                levels = linetype
              ),
            lines =
              unlist(x@meanEffFit)
          )

          ## linetypes for the plot
          lt <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 1
          )

          ## colour for the plot
          col <- c(
            "True Expected Efficacy" = 1,
            "Average estimated expected efficacy" = 4
          )

          ## now create and save the plot
          thisPlot <- ggplot() +
            geom_line(
              aes(
                x = dose,
                y = lines,
                group = group,
                linetype = linetype,
                col = linetype
              ),
              data = dat
            )

          thisPlot <- thisPlot +
            scale_linetype_manual(values = lt) +
            scale_colour_manual(values = col) +
            xlab("Dose level") +
            ylab("Expected Efficacy level")
        }

        ## add this plot to the bottom
        ret <-
          if (moreFromGeneral) {
            gridExtra::arrangeGrob(ret, thisPlot, heights = c(2 / 3, 1 / 3))
          } else {
            thisPlot
          }
      }

      ## then finally plot everything
      ret
    }
)

# nolint end

#' @include helpers.R
#' @include helpers_jags.R
#' @include Model-validity.R
#' @include ModelParams-class.R
#' @include CrmPackClass-class.R
NULL

# GeneralModel-class ----

#' `GeneralModel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralModel`] is a general model class, from which all other specific
#' model-like classes inherit.
#'
#' @note The `datamodel` must obey the convention that the data input is
#'   called exactly in the same way as in the corresponding data class.
#'   All prior distributions for parameters should be contained in the
#'   model function `priormodel`. The background is that this can
#'   be used to simulate from the prior distribution, before obtaining any data.
#'
#' @slot datamodel (`function`)\cr a function representing the `JAGS` data model
#'   specification.
#' @slot priormodel (`function`)\cr a function representing the `JAGS` prior
#'   specification.
#' @slot modelspecs (`function`)\cr a function computing the list of the data
#'   model and prior model specifications that are required to be specified
#'   completely (e.g. prior parameters, reference dose, etc.), based on the data
#'   slots that are required as arguments of this function.
#'   Apart of data arguments, this function can be specified with one additional
#'   (optional) argument `from_prior` of type `logical` and length one. This
#'   `from_prior` flag can be used to differentiate the output of the `modelspecs`,
#'   as its value is taken directly from the `from_prior` argument of the `mcmc`
#'   method that invokes `modelspecs` function. That is, when `from_prior` is
#'   `TRUE`, then only `priormodel` JAGS model is used (`datamodel` is not used)
#'   by the `mcmc`, and hence `modelspecs` function should return all the parameters
#'   that are required by the `priormodel` only. If the value of `from_prior` is
#'   `FALSE`, then both JAGS models `datamodel` and `priormodel` are used in the
#'   MCMC sampler, and hence `modelspecs` function should return all the parameters
#'   required by both `datamodel` and `priormodel`.
#' @slot init (`function`)\cr a function computing the list of starting values
#'   for parameters required to be initialized in the MCMC sampler, based on the
#'   data slots that are required as arguments of this function.
#' @slot datanames (`character`)\cr the names of all data slots that are used
#'   by `datamodel` JAGS function. No other names should be specified here.
#' @slot datanames_prior (`character`)\cr the names of all data slots that are
#'   used by `priormodel` JAGS function. No other names should be specified here.
#' @slot sample (`character`)\cr names of all parameters from which you would
#'   like to save the MCMC samples.
#'
#' @seealso [`ModelPseudo`].
#'
#' @aliases GeneralModel
#' @export
#'
.GeneralModel <- setClass(
  Class = "GeneralModel",
  slots = c(
    datamodel = "function",
    priormodel = "function",
    modelspecs = "function",
    init = "function",
    datanames = "character",
    datanames_prior = "character",
    sample = "character"
  ),
  prototype = prototype(
    datamodel = I,
    priormodel = I,
    init = function() {
      list()
    }
  ),
  contains = "CrmPackClass",
  validity = v_general_model
)

## default constructor ----

#' @rdname GeneralModel-class
#' @note Typically, end users will not use the `.DefaultGeneralModel()` function.
#' @export
.DefaultGeneralModel <- function() {
  stop(paste0("Class GeneralModel should not be instantiated directly.  Please use one of its subclasses instead."))
}


# ModelLogNormal ----

## class ----

#' `ModelLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelLogNormal`] is the class for a model with a reference dose and bivariate
#' normal prior on the model parameters `alpha0` and natural logarithm of `alpha1`,
#' i.e.: \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov),}. Transformations other
#' than `log`, e.g. identity, can be specified too in `priormodel` slot.
#' The parameter `alpha1` has a log-normal distribution by default to ensure
#' positivity of `alpha1` which further guarantees `exp(alpha1) > 1`.
#' The slots of this class contain the mean vector, the covariance and
#' precision matrices of the bivariate normal distribution, as well as the
#' reference dose. Note that the precision matrix is an inverse of the
#' covariance matrix in the `JAGS`.
#' All ("normal") model specific classes inherit from this class.
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`], [`ProbitLogNormalRel`].
#'
#' @aliases ModelLogNormal
#' @export
#'
.ModelLogNormal <- setClass(
  Class = "ModelLogNormal",
  contains = "GeneralModel",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "positive_number"
  )
)

## constructor ----

#' @rdname ModelLogNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*} (strictly positive
#'   number).
#'
#' @export
#'
ModelLogNormal <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .ModelLogNormal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname ModelLogNormal-class
#' @note Typically, end users will not use the `.DefaultModelLogNormal()` function.
#' @export
.DefaultModelLogNormal <- function() {
  ModelLogNormal(mean = c(-0.85, 1), cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2))
}

# LogisticNormal ----

## class ----

#' `LogisticNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormal`] is the class for the usual logistic regression model with
#' a bivariate normal prior on the intercept and slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, alpha1) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticNormalMixture`].
#'
#' @aliases LogisticNormal
#' @export
#'
.LogisticNormal <- setClass(
  Class = "LogisticNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticNormal.R
#'
LogisticNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    }
  )
}

## default constructor ----

#' @rdname LogisticNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticNormal()` function.
#' @export
.DefaultLogisticNormal <- function() {
  LogisticNormal(mean = c(-0.85, 1), cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2))
}


# LogisticLogNormal ----

## class ----

#' `LogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormal`] is the class for the usual logistic regression model
#' with a bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormalSub`],
#'   [`ProbitLogNormal`], [`ProbitLogNormalRel`], [`LogisticLogNormalMixture`],
#'   [`DALogisticLogNormal`].
#'
#' @aliases LogisticLogNormal
#' @export
#'
.LogisticLogNormal <- setClass(
  Class = "LogisticLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormal.R
#'
LogisticLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .LogisticLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname LogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormal()` function.
#' @export
.DefaultLogisticLogNormal <- function() {
  LogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# LogisticLogNormalSub ----

## class ----

#' `LogisticLogNormalSub`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalSub`] is the class for a standard logistic model with
#' bivariate (log) normal prior with subtractive dose standardization.
#'
#' @details The covariate is the dose \eqn{x} minus the reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * (x - x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @slot params (`ModelParamsNormal`)\cr bivariate normal prior parameters.
#' @slot ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @seealso [`LogisticNormal`], [`LogisticLogNormal`], [`ProbitLogNormal`],
#'   [`ProbitLogNormalRel`].
#'
#' @aliases LogisticLogNormalSub
#' @export
#'
.LogisticLogNormalSub <- setClass(
  Class = "LogisticLogNormalSub",
  slots = c(
    params = "ModelParamsNormal",
    ref_dose = "numeric"
  ),
  contains = "GeneralModel"
)

## constructor ----

#' @rdname LogisticLogNormalSub-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalSub.R
#'
LogisticLogNormalSub <- function(mean, cov, ref_dose = 0) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalSub(
    params = params,
    ref_dose = ref_dose,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * (x[i] - ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      alpha1 <- exp(theta[2])
    },
    modelspecs = function(from_prior) {
      ms <- list(mean = params@mean, prec = params@prec)
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, -20))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}


## default constructor ----

#' @rdname LogisticLogNormalSub-class
#' @note Typically, end-users will not use the `.DefaultLogisticLogNormalSub()` function.
#' @export
.DefaultLogisticLogNormalSub <- function() {
  LogisticLogNormalSub(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# ProbitLogNormal ----

## class ----

#' `ProbitLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormal`] is the class for probit regression model with a
#' bivariate normal prior on the intercept and log slope.
#'
#' @details The covariate is the natural logarithm of dose \eqn{x} divided by a
#'   reference dose \eqn{x*}, i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note This model is also used in the [`DualEndpoint`] classes, so this class
#'   can be used to check the prior assumptions on the dose-toxicity model, even
#'   when sampling from the prior distribution of the dual endpoint model is not
#'   possible.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormalRel`].
#'
#' @aliases ProbitLogNormalLogDose
#' @export
#'
.ProbitLogNormal <- setClass(
  Class = "ProbitLogNormal",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormal-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormal.R
#'
ProbitLogNormal <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormal(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormal-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormal()` function.
#' @export
.DefaultProbitLogNormal <- function() {
  ProbitLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 7.2
  )
}

# ProbitLogNormalRel ----

## class ----

#' `ProbitLogNormalRel`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ProbitLogNormalRel`] is the class for probit regression model with a bivariate
#' normal prior on the intercept and log slope.
#'
#' @details The covariate is the dose \eqn{x} divided by a reference dose \eqn{x*},
#'   i.e.:
#'   \deqn{probit[p(x)] = alpha0 + alpha1 * x/x*,}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior \deqn{(alpha0, log(alpha1)) ~ Normal(mean, cov).}
#'
#' @note This model is also used in the [`DualEndpoint`] classes, so this class
#'   can be used to check the prior assumptions on the dose-toxicity model, even
#'   when sampling from the prior distribution of the dual endpoint model is not
#'   possible.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`],
#'   [`LogisticLogNormalSub`], [`ProbitLogNormal`].
#'
#' @aliases ProbitLogNormalRel
#' @export
#'
.ProbitLogNormalRel <- setClass(
  Class = "ProbitLogNormalRel",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname ProbitLogNormalRel-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-ProbitLogNormalRel.R
#'
ProbitLogNormalRel <- function(mean, cov, ref_dose = 1) {
  model_ln <- ModelLogNormal(mean = mean, cov = cov, ref_dose = ref_dose)

  .ProbitLogNormalRel(
    model_ln,
    datamodel = function() {
      for (i in 1:nObs) {
        probit(p[i]) <- alpha0 + alpha1 * (x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    }
  )
}

## default constructor ----

#' @rdname ProbitLogNormalRel-class
#' @note Typically, end users will not use the `.DefaultProbitLogNormalRel()` function.
#' @export
.DefaultProbitLogNormalRel <- function() {
  ProbitLogNormalRel(mean = c(-0.85, 1), cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2))
}

# LogisticLogNormalGrouped ----

## class ----

#' `LogisticLogNormalGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalGrouped`] is the class for a logistic regression model
#'  for both the mono and the combo arms of the simultaneous dose escalation
#'  design.
#'
#' @details The continuous covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*} as in [`LogisticLogNormal`]. In addition,
#'   \eqn{I_c} is a binary indicator covariate which is 1 for the combo arm and 0 for the mono arm.
#'   The model is then defined as:
#'   \deqn{logit[p(x)] = (alpha0 + I_c * delta0) + (alpha1 + I_c * delta1) * log(x / x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x},
#'   and `delta0` and `delta1` are the differences in the combo arm compared to the mono intercept
#'   and slope parameters `alpha0` and `alpha1`.
#'   The prior is defined as \deqn{(alpha0, log(delta0), log(alpha1), log(delta1)) ~ Normal(mean, cov).}
#'
#' @seealso [`ModelLogNormal`], [`LogisticLogNormal`].
#'
#' @aliases LogisticLogNormalGrouped
#' @export
#'
.LogisticLogNormalGrouped <- setClass(
  Class = "LogisticLogNormalGrouped",
  contains = "ModelLogNormal"
)

## constructor ----

#' @rdname LogisticLogNormalGrouped-class
#'
#' @inheritParams ModelLogNormal
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalGrouped.R
#'
LogisticLogNormalGrouped <- function(mean, cov, ref_dose = 1) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalGrouped(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      theta ~ dmnorm(mean, prec)
      alpha0 <- theta[1]
      delta0 <- exp(theta[2])
      alpha1 <- exp(theta[3])
      delta1 <- exp(theta[4])
    },
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (alpha0 + is_combo[i] * delta0) +
          (alpha1 + is_combo[i] * delta1) * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    modelspecs = function(group, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
        ms$is_combo <- as.integer(group == "combo")
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1, 1, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "delta0", "alpha1", "delta1")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalGrouped-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalGrouped()` function.
#' @export
.DefaultLogisticLogNormalGrouped <- function() {
  LogisticLogNormalGrouped(
    mean = rep(0, 4),
    cov = diag(rep(1, 4)),
  )
}

# LogisticKadane ----

## class ----

#' `LogisticKadane`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticKadane`] is the class for the logistic model in the parametrization
#' of Kadane et al. (1980).
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The priors are \deqn{gamma ~ Unif(xmin, xmax).} and
#'   \deqn{rho0 ~ Unif(0, theta).}
#'
#' @note The slots of this class, required for creating the model, are the target
#'   toxicity, as well as the minimum and maximum of the dose range. Note that
#'   these can be different from the minimum and maximum of the dose grid in the
#'   data later on.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#'
#' @seealso [`ModelLogNormal`]
#'
#' @aliases LogisticKadane
#' @export
#'
.LogisticKadane <- setClass(
  Class = "LogisticKadane",
  contains = "GeneralModel",
  slots = c(
    theta = "numeric",
    xmin = "numeric",
    xmax = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1
  ),
  validity = v_model_logistic_kadane
)

## constructor ----

#' @rdname LogisticKadane-class
#'
#' @param theta (`proportion`)\cr the target toxicity probability.
#' @param xmin (`number`)\cr the minimum of the dose range.
#' @param xmax (`number`)\cr the maximum of the dose range.
#'
#' @export
#' @example examples/Model-class-LogisticKadane.R
#'
LogisticKadane <- function(theta, xmin, xmax) {
  .LogisticKadane(
    theta = theta,
    xmin = xmin,
    xmax = xmax,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- (1 / (gamma - xmin)) *
          (gamma * logit(rho0) - xmin * logit(theta) + x[i] * (logit(theta) - logit(rho0)))
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      rho0 ~ dunif(0, theta)
      gamma ~ dunif(xmin, xmax)
    },
    modelspecs = function() {
      list(theta = theta, xmin = xmin, xmax = xmax)
    },
    init = function() {
      list(rho0 = theta / 10, gamma = (xmax - xmin) / 2)
    },
    datanames = c("nObs", "y", "x"),
    sample = c("rho0", "gamma")
  )
}

## default constructor ----

#' @rdname LogisticKadane-class
#' @note Typically, end-users will not use the `.DefaultLogisticKadane()` function.
#' @export
.DefaultLogisticKadane <- function() {
  LogisticKadane(theta = 0.33, xmin = 1, xmax = 200)
}


# LogisticKadaneBetaGamma ----

## class ----

#' `LogisticKadaneBetaGamma`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticKadaneBetaGamma`] is the class for the logistic model in the parametrization
#' of Kadane et al. (1980), using a beta and a gamma distribution as the model priors.
#'
#' @details Let `rho0 = p(xmin)` be the probability of a DLT at the minimum dose
#'   `xmin`, and let `gamma` be the dose with target toxicity probability `theta`,
#'   i.e. \eqn{p(gamma) = theta}. Then it can easily be shown that the logistic
#'   regression model has intercept
#'   \deqn{[gamma * logit(rho0) - xmin * logit(theta)] / [gamma - xmin]}
#'   and slope
#'   \deqn{[logit(theta) - logit(rho0)] / [gamma - xmin].}
#'
#'   The prior for `gamma`, is \deqn{gamma ~ Gamma(shape, rate).}.
#'   The prior for `rho0 = p(xmin)`, is \deqn{rho0 ~ Beta(alpha, beta).}
#'
#' @note The slots of this class, required for creating the model, are the same
#'   as in the `LogisticKadane` class. In addition, the shape parameters of the
#'   Beta prior distribution of `rho0` and the shape and rate parameters of the
#'   Gamma prior distribution of `gamma`, are required for creating the prior model.
#'
#' @slot theta (`proportion`)\cr the target toxicity probability.
#' @slot xmin (`number`)\cr the minimum of the dose range.
#' @slot xmax (`number`)\cr the maximum of the dose range.
#' @slot alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   of `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @slot shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#' @slot rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   of `gamma` the dose with target toxicity probability `theta`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticKadane`].
#'
#' @aliases LogisticKadaneBetaGamma
#' @export
#'
.LogisticKadaneBetaGamma <- setClass(
  Class = "LogisticKadaneBetaGamma",
  contains = "LogisticKadane",
  slots = c(
    alpha = "numeric",
    beta = "numeric",
    shape = "numeric",
    rate = "numeric"
  ),
  prototype = prototype(
    theta = 0.3,
    xmin = 0.1,
    xmax = 1,
    alpha = 1,
    beta = 0.5,
    shape = 1.2,
    rate = 2.5
  ),
  validity = v_model_logistic_kadane_beta_gamma
)

## constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#'
#' @inheritParams LogisticKadane
#'
#' @param alpha (`number`)\cr the first shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param beta (`number`)\cr the second shape parameter of the Beta prior distribution
#'   `rho0 = p(xmin)` the probability of a DLT at the minimum dose `xmin`.
#' @param shape (`number`)\cr the shape parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#' @param rate (`number`)\cr the rate parameter of the Gamma prior distribution
#'   `gamma` the dose with target toxicity probability `theta`.
#'
#' @export
#' @example examples/Model-class-LogisticKadaneBetaGamma.R
#'
LogisticKadaneBetaGamma <- function(theta, xmin, xmax, alpha, beta, shape, rate) {
  model_lk <- LogisticKadane(theta = theta, xmin = xmin, xmax = xmax)
  .LogisticKadaneBetaGamma(
    model_lk,
    alpha = alpha,
    beta = beta,
    shape = shape,
    rate = rate,
    priormodel = function() {
      rho0 ~ dbeta(alpha, beta)
      gamma ~ dgamma(shape, rate)
      lowestdose <- xmin
      highestdose <- xmax
      DLTtarget <- theta
    },
    modelspecs = function() {
      list(
        theta = theta,
        xmin = xmin,
        xmax = xmax,
        alpha = alpha,
        beta = beta,
        shape = shape,
        rate = rate
      )
    }
  )
}

## default constructor ----

#' @rdname LogisticKadaneBetaGamma-class
#' @note Typically, end users will not use the `.Default()` function.
#' @export
.DefaultLogisticKadaneBetaGamma <- function() {
  LogisticKadaneBetaGamma(
    theta = 0.3,
    xmin = 0,
    xmax = 7,
    alpha = 1,
    beta = 19,
    shape = 0.5625,
    rate = 0.125
  )
}

# LogisticNormalMixture ----

## class ----

#' `LogisticNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalMixture`] is the class for standard logistic regression model
#' with a mixture of two bivariate normal priors on the intercept and slope parameters.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided by
#'   the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w * Normal(mean1, cov1) + (1 - w) * Normal(mean2, cov2).}
#'   The weight w for the first component is assigned a beta prior `B(a, b)`.
#'
#' @note The weight of the two normal priors is a model parameter, hence it is a
#'   flexible mixture. This type of prior is often used with a mixture of a minimal
#'   informative and an informative component, in order to make the CRM more robust
#'   to data deviations from the informative component.
#'
#' @slot comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component.
#' @slot comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component.
#' @slot weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalFixedMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalMixture
#' @export
#'
.LogisticNormalMixture <- setClass(
  Class = "LogisticNormalMixture",
  contains = "GeneralModel",
  slots = c(
    comp1 = "ModelParamsNormal",
    comp2 = "ModelParamsNormal",
    weightpar = "numeric",
    ref_dose = "numeric"
  ),
  prototype = prototype(
    comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2)),
    weightpar = c(a = 1, b = 1),
    ref_dose = 1
  ),
  validity = v_model_logistic_normal_mix
)

## constructor ----

#' @rdname LogisticNormalMixture-class
#'
#' @param comp1 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the first component. See [`ModelParamsNormal`] for more details.
#' @param comp2 (`ModelParamsNormal`)\cr bivariate normal prior specification of
#'   the second component. See [`ModelParamsNormal`] for more details.
#' @param weightpar (`numeric`)\cr the beta parameters for the weight of the
#'   first component. It must a be a named vector of length 2 with names `a` and
#'   `b` and with strictly positive values.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#'
#' @export
#' @example examples/Model-class-LogisticNormalMixture.R
#'
LogisticNormalMixture <- function(comp1,
                                  comp2,
                                  weightpar,
                                  ref_dose) {
  assert_number(ref_dose)

  .LogisticNormalMixture(
    comp1 = comp1,
    comp2 = comp2,
    weightpar = weightpar,
    ref_dose = ref_dose,
    datamodel = function() {
      # The logistic likelihood - the same as for non-mixture case.
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      w ~ dbeta(weightpar[1], weightpar[2])
      wc <- 1 - w
      comp0 ~ dbern(wc)
      comp <- comp0 + 1
      # Conditional on the component index "comp", which is  1 or 2.
      # comp = 1 with probability "w" and comp = 2 with probability "1 - w".
      theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
      alpha0 <- theta[1]
      alpha1 <- theta[2]
    },
    modelspecs = function(from_prior) {
      ms <- list(
        mean = cbind(comp1@mean, comp2@mean),
        prec = array(data = c(comp1@prec, comp2@prec), dim = c(2, 2, 2)),
        weightpar = weightpar
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1", "w")
  )
}

## default constructor ----

#' @rdname LogisticNormalMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalMixture()` function.
#' @export
.DefaultLogisticNormalMixture <- function() { # nolint
  LogisticNormalMixture(
    comp1 = ModelParamsNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
    ),
    comp2 = ModelParamsNormal(
      mean = c(1, 1.5),
      cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
    ),
    weightpar = c(a = 1, b = 1),
    ref_dose = 50
  )
}

# LogisticNormalFixedMixture ----

## class ----

#' `LogisticNormalFixedMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticNormalFixedMixture`] is the class for standard logistic regression
#' model with fixed mixture of multiple bivariate (log) normal priors on the
#' intercept and slope parameters. The weights of the normal priors are fixed,
#' hence no additional model parameters are introduced. This type of prior is
#' often used to better approximate a given posterior distribution, or when the
#' information is given in terms of a mixture.
#'
#' @details The covariate is the natural logarithm of the dose \eqn{x} divided
#'   by the reference dose \eqn{x*}, i.e.:
#'   \deqn{logit[p(x)] = alpha0 + alpha1 * log(x/x*),}
#'   where \eqn{p(x)} is the probability of observing a DLT for a given dose \eqn{x}.
#'   The prior
#'   \deqn{(alpha0, alpha1) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a normal prior is used and
#'   \deqn{(alpha0, log(alpha1)) ~ w1 * Normal(mean1, cov1) + ... + wK * Normal(meanK, covK),}
#'   if a log normal prior is used.
#'   The weights \eqn{w1, ..., wK} of the components are fixed and sum to 1.
#'
#'   The slots of this class comprise a list with components parameters. Every
#'   single component contains the mean vector and the covariance matrix of
#'   bivariate normal distributions. Remaining slots are the weights of the
#'   components as well as the reference dose. Moreover, a special indicator
#'   slot specifies whether a log normal prior is used.
#'
#' @slot components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @slot weights (`numeric`)\cr the weights of the components; these must be
#'   positive and must sum to 1.
#' @slot ref_dose (`positive_number`)\cr the reference dose.
#' @slot log_normal (`flag`)\cr should a log normal prior be used, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @seealso [`ModelParamsNormal`], [`ModelLogNormal`],
#'   [`LogisticNormalMixture`], [`LogisticLogNormalMixture`].
#'
#' @aliases LogisticNormalFixedMixture
#' @export
#'
.LogisticNormalFixedMixture <- setClass(
  Class = "LogisticNormalFixedMixture",
  contains = "GeneralModel",
  slots = c(
    components = "list",
    weights = "numeric",
    ref_dose = "numeric",
    log_normal = "logical"
  ),
  prototype = prototype(
    components = list(
      comp1 = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
      comp2 = ModelParamsNormal(mean = c(-1, 1), cov = diag(2))
    ),
    weights = c(0.5, 0.5),
    ref_dose = 1,
    log_normal = FALSE
  ),
  validity = v_model_logistic_normal_fixed_mix
)

## constructor ----

#' @rdname LogisticNormalFixedMixture-class
#'
#' @param components (`list`)\cr the specifications of the mixture components,
#'   a list with [`ModelParamsNormal`] objects for each bivariate (log) normal
#'   prior.
#' @param weights (`numeric`)\cr the weights of the components; these must be
#'   positive and will be normalized to sum to 1.
#' @param ref_dose (`number`)\cr the reference dose \eqn{x*}
#'   (strictly positive number).
#' @param log_normal (`flag`)\cr should a log normal prior be specified, such
#'   that the mean vectors and covariance matrices are valid for the intercept
#'   and log slope?
#'
#' @export
#' @example examples/Model-class-LogisticNormalFixedMixture.R
#'
LogisticNormalFixedMixture <- function(components,
                                       weights,
                                       ref_dose,
                                       log_normal = FALSE) {
  assert_numeric(weights)
  assert_number(ref_dose)
  assert_flag(log_normal)

  # Normalize weights to sum to 1.
  weights <- weights / sum(weights)

  .LogisticNormalFixedMixture(
    components = components,
    weights = weights,
    ref_dose = positive_number(ref_dose),
    log_normal = log_normal,
    datamodel = function() {
      for (i in 1:nObs) {
        logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = if (log_normal) {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- exp(theta[2])
      }
    } else {
      function() {
        comp ~ dcat(weights)
        theta ~ dmnorm(mean[1:2, comp], prec[1:2, 1:2, comp])
        alpha0 <- theta[1]
        alpha1 <- theta[2]
      }
    },
    modelspecs = function(from_prior) {
      ms <- list(
        weights = weights,
        mean = do.call(cbind, lapply(components, h_slots, "mean", simplify = TRUE)),
        prec = array(
          do.call(c, lapply(components, h_slots, "prec", simplify = TRUE)),
          dim = c(2, 2, length(components))
        )
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = c(0, 1))
    },
    datanames = c("nObs", "y", "x"),
    sample = c("alpha0", "alpha1")
  )
}

## default constructor ----

#' @rdname LogisticNormalFixedMixture-class
#' @note Typically, end-users will not use the `.DefaultLogisticNormalFixedMixture()`
#' function.
#' @export
.DefaultLogisticNormalFixedMixture <- function() { # nolint
  LogisticNormalFixedMixture(
    components = list(
      comp1 = ModelParamsNormal(
        mean = c(-0.85, 1),
        cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2)
      ),
      comp2 = ModelParamsNormal(
        mean = c(1, 1.5),
        cov = matrix(c(1.2, -0.45, -0.45, 0.6), nrow = 2)
      )
    ),
    weights = c(0.3, 0.7),
    ref_dose = 50
  )
}

# LogisticLogNormalMixture ----

## class ----

#' `LogisticLogNormalMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticLogNormalMixture`] is the class for standard logistic model with
#' online mixture of two bivariate log normal priors.
#'
#' @details This model can be used when data is arising online from the informative
#'   component of the prior, at the same time with the data of the trial of
#'   main interest. Formally, this is achieved by assuming that the probability
#'   of a DLT at dose \eqn{x} is given by
#'   \deqn{p(x) = \pi * p1(x) + (1 - \pi) * p2(x)}
#'   where \eqn{\pi} is the probability for the model \eqn{p(x)} being the same
#'   as the model \eqn{p1(x)}, which is the informative component of the prior.
#'   From this model data arises in parallel: at doses `xshare`, DLT information
#'   `yshare` is observed, in total `nObsshare` data points (see [`DataMixture`]).
#'   On the other hand, \eqn{1 - \pi}, is the probability of a separate model
#'   \eqn{p2(x)}. Both components have the same log normal prior distribution,
#'   which can be specified by the user, and which is inherited from the
#'   [`LogisticLogNormal`] class.
#'
#' @slot share_weight (`proportion`)\cr the prior weight for the share component
#'   \eqn{p_{1}(x)}.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`],
#'   [`LogisticNormalFixedMixture`].
#'
#' @aliases LogisticLogNormalMixture
#' @export
#'
.LogisticLogNormalMixture <- setClass(
  Class = "LogisticLogNormalMixture",
  contains = "LogisticLogNormal",
  slots = c(
    share_weight = "numeric"
  ),
  prototype = prototype(
    share_weight = 0.1
  ),
  validity = v_model_logistic_log_normal_mix
)

## constructor ----

#' @rdname LogisticLogNormalMixture-class
#'
#' @inheritParams ModelLogNormal
#' @param share_weight (`proportion`)\cr the prior weight for the share component.
#'
#' @export
#' @example examples/Model-class-LogisticLogNormalMixture.R
#'
LogisticLogNormalMixture <- function(mean,
                                     cov,
                                     ref_dose,
                                     share_weight) {
  assert_number(ref_dose)

  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalMixture(
    params = params,
    ref_dose = positive_number(ref_dose),
    share_weight = share_weight,
    datamodel = function() {
      for (i in 1:nObs) {
        # comp gives the component: non-informative (1) or share (2) the two components.
        stand_log_dose[i] <- log(x[i] / ref_dose)
        logit(p[i]) <- alpha0[comp] + alpha1[comp] * stand_log_dose[i]
        y[i] ~ dbern(p[i])
      }
      for (j in 1:nObsshare) {
        stand_log_dose_share[j] <- log(xshare[j] / ref_dose)
        logit(pshare[j]) <- alpha0[2] + alpha1[2] * stand_log_dose_share[j]
        yshare[j] ~ dbern(pshare[j])
      }
    },
    priormodel = function() {
      for (k in 1:2) {
        theta[k, 1:2] ~ dmnorm(mean, prec)
        alpha0[k] <- theta[k, 1]
        alpha1[k] <- exp(theta[k, 2])
      }
      # The component indicator.
      comp ~ dcat(cat_probs)
    },
    modelspecs = function(from_prior) {
      ms <- list(
        cat_probs = c(1 - share_weight, share_weight),
        mean = params@mean,
        prec = params@prec
      )
      if (!from_prior) {
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(theta = matrix(c(0, 0, 1, 1), nrow = 2))
    },
    datanames = c("nObs", "y", "x", "nObsshare", "yshare", "xshare"),
    sample = c("alpha0", "alpha1", "comp")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalMixture-class
#' @note Typically, end users will not use the `.DefaultLogNormalMixture()` function.
#' @export
.DefaultLogisticLogNormalMixture <- function() { # nolint
  LogisticLogNormalMixture(
    share_weight = 0.1,
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 50
  )
}

# DualEndpoint ----

## class ----

#' `DualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpoint`] is the general class for the dual endpoint model.
#'
#' @details The idea of the dual-endpoint models is to model not only the
#'   dose-toxicity relationship, but also to model, at the same time, the
#'   relationship of a PD biomarker with the dose. The sub-classes of this class
#'   define how the dose-biomarker relationship is parametrized. This class here
#'   shall contain all the common features to reduce duplicate code.
#'   (This class however, must not be virtual as we need to create objects
#'   of it during the construction of subclass objects.)
#'
#'   The dose-toxicity relationship is modeled with probit regression model
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * x/x*,}
#'   or
#'   \deqn{probit[p(x)] = betaZ1 + betaZ2 * log(x/x*),}
#'   in case when the option `use_log_dose` is `TRUE`.
#'   Here, \eqn{p(x)} is the probability of observing a DLT for a given
#'   dose \eqn{x} and \eqn{x*} is the reference dose.
#'   The prior \deqn{(betaZ1, log(betaZ2)) ~ Normal(mean, cov).}
#'
#'   For the biomarker response \eqn{w} at a dose \eqn{x}, we assume
#'   \deqn{w(x) ~ Normal(f(x), sigma2W),}
#'   where \eqn{f(x)} is a function of the dose \eqn{x}, which is further
#'   specified in sub-classes. The biomarker variance \eqn{sigma2W} can be fixed
#'   or assigned an Inverse-Gamma prior distribution; see the details below under
#'   slot `sigma2W`.
#'
#'   Finally, the two endpoints \eqn{y} (the binary DLT variable) and \eqn{w}
#'   (the biomarker) can be correlated, by assuming a correlation of level
#'   \eqn{rho} between the underlying continuous latent toxicity variable \eqn{z}
#'   and the biomarker \eqn{w}. Again, this correlation can be fixed or assigned
#'   a prior distribution from the scaled Beta family; see the details below
#'   under slot `rho`.
#'
#'   Please see the example vignette by typing `crmPackExample()` for a full example.
#'
#' @slot betaZ_params (`ModelParamsNormal`)\cr for the probit toxicity model, it
#'   contains the prior mean, covariance matrix and precision matrix which is
#'   internally calculated as an inverse of the covariance matrix.
#' @slot ref_dose (`positive_number`)\cr for the probit toxicity model, the
#'   reference dose.
#' @slot use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @slot sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @slot rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for `sigma2W`
#'   or `rho` (for each parameter separately) is used or not. This slot is
#'   needed for internal purposes and must not be touched by the user.
#'
#' @seealso [`DualEndpointRW`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpoint
#' @export
#'
.DualEndpoint <- setClass(
  Class = "DualEndpoint",
  slots = c(
    betaZ_params = "ModelParamsNormal",
    ref_dose = "positive_number",
    use_log_dose = "logical",
    sigma2W = "numeric",
    rho = "numeric",
    use_fixed = "logical"
  ),
  prototype = prototype(
    betaZ_params = ModelParamsNormal(mean = c(0, 1), cov = diag(2)),
    ref_dose = positive_number(1),
    use_log_dose = FALSE,
    sigma2W = 1,
    rho = 0,
    use_fixed = c(sigma2W = TRUE, rho = TRUE)
  ),
  contains = "GeneralModel",
  validity = v_model_dual_endpoint
)

## constructor ----

#' @rdname DualEndpoint-class
#'
#' @param mean (`numeric`)\cr for the probit toxicity model, the prior mean vector.
#' @param cov (`matrix`)\cr for the probit toxicity model, the prior covariance
#'   matrix. The precision matrix is internally calculated as an inverse of `cov`.
#' @param ref_dose (`number`)\cr for the probit toxicity model, the reference
#'   dose \eqn{x*} (strictly positive number).
#' @param use_log_dose (`flag`)\cr for the probit toxicity model, whether a log
#'   transformation of the (standardized) dose should be used?
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param rho (`numeric`)\cr either a fixed value for the correlation
#'   (between `-1` and `1`), or a named vector with two elements named `a` and `b`
#'   for the Beta prior on the transformation `kappa = (rho + 1) / 2`, which is
#'   in `(0, 1)`. For example, `a = 1, b = 1` leads to a uniform prior on `rho`.
#'
#' @export
#'
DualEndpoint <- function(mean,
                         cov,
                         ref_dose = 1,
                         use_log_dose = FALSE,
                         sigma2W,
                         rho) {
  assert_number(ref_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(rho, min.len = 1, max.len = 2)

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    rho = test_number(rho)
  )
  beta_z_params <- ModelParamsNormal(mean, cov)

  datamodel <- function() {
    for (i in 1:nObs) {
      # The toxicity model.
      stand_dose_temp[i] <- x[i] / ref_dose
      stand_dose[i] <- ifelse(use_log_dose, log(stand_dose_temp[i]), stand_dose_temp[i])
      meanZ[i] <- betaZ[1] + betaZ[2] * stand_dose[i]
      z[i] ~ dnorm(meanZ[i], 1)
      y[i] ~ dinterval(z[i], 0)

      # The conditional biomarker model; betaW defined in subclasses!
      condMeanW[i] <- betaW[xLevel[i]] + rho / sqrt(precW) * (z[i] - meanZ[i])
      w[i] ~ dnorm(condMeanW[i], condPrecW)
    }
  }
  priormodel <- function() {
    # Priors for betaW defined in subclasses!
    theta ~ dmnorm(betaZ_mean, betaZ_prec)
    betaZ[1] <- theta[1]
    betaZ[2] <- exp(theta[2])
    # Conditional precision for biomarker.
    # Code for `precW` and `rho` will be added by
    # `h_model_dual_endpoint_sigma2W()`, `h_model_dual_endpoint_rho()` helpers, below.
    condPrecW <- precW / (1 - pow(rho, 2))
  }
  modelspecs_prior <- list(
    betaZ_mean = beta_z_params@mean,
    betaZ_prec = beta_z_params@prec
  )

  comp <- list(
    priormodel = priormodel,
    modelspecs = modelspecs_prior,
    init = NULL,
    sample = "betaZ"
  )

  # Update model components with regard to biomarker regression variance.
  comp <- h_model_dual_endpoint_sigma2W(
    use_fixed["sigma2W"],
    sigma2W = sigma2W,
    comp = comp
  )

  # Update model components with regard to DLT and biomarker correlation.
  comp <- h_model_dual_endpoint_rho(
    use_fixed["rho"],
    rho = rho,
    comp = comp
  )

  .DualEndpoint(
    betaZ_params = beta_z_params,
    ref_dose = positive_number(ref_dose),
    use_log_dose = use_log_dose,
    sigma2W = sigma2W,
    rho = rho,
    use_fixed = use_fixed,
    datamodel = datamodel,
    priormodel = comp$priormodel,
    modelspecs = function(from_prior) {
      if (!from_prior) {
        comp$modelspecs$ref_dose <- ref_dose
        comp$modelspecs$use_log_dose <- use_log_dose
      }
      comp$modelspecs
    },
    init = function(y) {
      c(comp$init, list(z = ifelse(y == 0, -1, 1), theta = c(0, 1)))
    },
    datanames = c("nObs", "w", "x", "xLevel", "y"),
    sample = comp$sample
  )
}

## default constructor ----

#' @rdname DualEndpoint-class
#' @note Typically, end users will not use the `.DefaultDualEndpoint()` function.
#' @export
.DefaultDualEndpoint <- function() {
  stop(paste0("Class DualEndpoint cannot be instantiated directly.  Please use one of its subclasses instead."))
}

# DualEndpointRW ----

## class ----

#' `DualEndpointRW`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointRW`] is the class for the dual endpoint model with random walk
#' prior for biomarker.
#'
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a non-parametric random walk of first
#'   or second order. That means, for the first order random walk we assume
#'   \deqn{betaW_i - betaW_i-1 ~ Normal(0, (x_i - x_i-1) * sigma2betaW),}
#'   where \eqn{betaW_i = f(x_i)} is the biomarker mean at the \eqn{i}-th dose
#'   gridpoint \eqn{x_i}.
#'   For the second order random walk, the second-order differences instead of
#'   the first-order differences of the biomarker means follow the normal distribution
#'   with \eqn{0} mean and \eqn{2 * (x_i - x_i-2) * sigma2betaW} variance.
#'
#'   The variance parameter \eqn{sigma2betaW} is important because it steers the
#'   smoothness of the function \eqn{f(x)}, i.e.: if it is large, then \eqn{f(x)}
#'   will be very wiggly; if it is small, then \eqn{f(x)} will be smooth.
#'   This parameter can either be a fixed value or assigned an inverse gamma prior
#'   distribution.
#'
#' @note Non-equidistant dose grids can be used now, because the difference
#'   \eqn{x_i - x_i-1} is included in the modelling assumption above.
#'   Please note that due to impropriety of the random walk prior distributions,
#'   it is not possible to produce MCMC samples with empty data objects (i.e.,
#'   sample from the prior). This is not a bug, but a theoretical feature of this
#'   model.
#'
#' @slot sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @slot rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#'
#' @seealso [`DualEndpoint`], [`DualEndpointBeta`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointRW
#' @export
#'
.DualEndpointRW <- setClass(
  Class = "DualEndpointRW",
  slots = c(
    sigma2betaW = "numeric",
    rw1 = "logical"
  ),
  prototype = prototype(
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      sigma2betaW = TRUE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_rw
)

## constructor ----

#' @rdname DualEndpointRW-class
#'
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param rw1 (`flag`)\cr for specifying the random walk prior on the biomarker
#'   level. When `TRUE`, random walk of first order is used. Otherwise, the
#'   random walk of second order is used.
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointRW.R
#'
DualEndpointRW <- function(sigma2betaW,
                           rw1 = TRUE,
                           ...) {
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)

  start <- DualEndpoint(...)
  start@use_fixed["sigma2betaW"] <- length(sigma2betaW) == 1L

  priormodel <- if (rw1) {
    function() {
      # The 1st order differences.
      # Essentially dflat(), which is not available in JAGS.
      betaW[1] ~ dnorm(0, 0.000001)
      for (i in 2:nGrid) {
        delta[i - 1] ~ dnorm(0, precBetaW / (doseGrid[i] - doseGrid[i - 1]))
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  } else {
    function() {
      # The 2nd order differences.
      delta[1] ~ dnorm(0, 0.000001)
      betaW[1] ~ dnorm(0, 0.000001)
      betaW[2] <- betaW[1] + delta[1]
      for (i in 3:nGrid) {
        # delta2: differences of the differences of betaW follow normal dist.
        delta2[i - 2] ~ dnorm(0, 2 * precBetaW / (doseGrid[i] - doseGrid[i - 2]))
        delta[i - 1] <- delta[i - 2] + delta2[i - 2]
        betaW[i] <- betaW[i - 1] + delta[i - 1]
      }
    }
  }
  start@priormodel <- h_jags_join_models(start@priormodel, priormodel)
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW", "delta")

  # Update model components with regard to biomarker regression variance.
  start <- h_model_dual_endpoint_sigma2betaW(
    start@use_fixed["sigma2betaW"],
    sigma2betaW = sigma2betaW,
    de = start
  )

  .DualEndpointRW(
    start,
    sigma2betaW = sigma2betaW,
    rw1 = rw1
  )
}

## default constructor ----

#' @rdname DualEndpointRW-class
#' @note Typically, end users will not use the `.DefaultDualEndpointRW()` function.
#' @export
.DefaultDualEndpointRW <- function() {
  DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    sigma2betaW = 0.01,
    rw1 = TRUE
  )
}

# DualEndpointBeta ----

## class ----

#' `DualEndpointBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointBeta`] is the class for the dual endpoint model with beta
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric, rescaled beta density
#'   function:
#'   \deqn{f(x) = E0 + (Emax - E0) * Beta(delta1, delta2) * (x/x*)^{delta1} * (1 - x/x*)^{delta2},}
#'   where \eqn{x*} is the maximum dose (end of the dose range to be considered),
#'   \eqn{delta1} and \eqn{delta2} are the two beta function parameters, and
#'   \eqn{E0}, \eqn{Emax} are the minimum and maximum levels, respectively.
#'   For ease of interpretation, we use the parametrization based on \eqn{delta1}
#'   and the mode, where
#'   \deqn{mode = delta1 / (delta1 + delta2),}
#'   so that multiplying this by \eqn{x*} gives the mode on the dose grid.
#'
#'   All parameters can currently be assigned uniform distributions or be fixed
#'   in advance. Note that \code{E0} and \code{Emax} can have negative values or
#'   uniform distributions reaching into negative range, while \code{delta1} and
#'   \code{mode} must be positive or have uniform distributions in the positive
#'   range.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot delta1 (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot mode (`numeric`)\cr either a fixed positive number or the two
#'   parameters of the uniform distribution, that can take only positive values.
#' @slot ref_dose_beta (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointEmax`].
#'
#' @aliases DualEndpointBeta
#' @export
#'
.DualEndpointBeta <- setClass(
  Class = "DualEndpointBeta",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    delta1 = "numeric",
    mode = "numeric",
    ref_dose_beta = "positive_number"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      delta1 = FALSE,
      mode = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_beta
)

## constructor ----

#' @rdname DualEndpointBeta-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param delta1 (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param mode (`numeric`)\cr either a fixed positive number or the two parameters
#'   of the uniform distribution, that can take only positive values.
#' @param ref_dose_beta (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointBeta.R
#'
DualEndpointBeta <- function(E0,
                             Emax,
                             delta1,
                             mode,
                             ref_dose_beta = 1,
                             ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(delta1, min.len = 1, max.len = 2)
  assert_numeric(mode, min.len = 1, max.len = 2)
  assert_number(ref_dose_beta)

  start <- DualEndpoint(...)

  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_beta = ref_dose_beta), ms(from_prior))
  }
  start@datanames_prior <- c("nGrid", "doseGrid")
  start@sample <- c(start@sample, "betaW")

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = delta1,
    param_name = "delta1",
    priormodel = function() {
      delta1 ~ dunif(delta1_low, delta1_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = mode,
    param_name = "mode",
    priormodel = function() {
      mode ~ dunif(mode_low, mode_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      # delta2 <- delta1 * (1 - (mode/ref_dose_beta)) / (mode/ref_dose_beta) # nolint
      delta2 <- delta1 * (ref_dose_beta / mode - 1)
      # betafun <- (delta1 + delta2)^(delta1 + delta2) * delta1^(- delta1) * delta2^(- delta2) # nolint
      betafun <- (1 + delta2 / delta1)^delta1 * (delta1 / delta2 + 1)^delta2
      for (i in 1:nGrid) {
        stand_dose_beta[i] <- doseGrid[i] / ref_dose_beta
        betaW[i] <- E0 + (Emax - E0) * betafun * stand_dose_beta[i]^delta1 * (1 - stand_dose_beta[i])^delta2
      }
    }
  )

  .DualEndpointBeta(
    start,
    E0 = E0,
    Emax = Emax,
    delta1 = delta1,
    mode = mode,
    ref_dose_beta = positive_number(ref_dose_beta)
  )
}

## default constructor ----

#' @rdname DualEndpointBeta-class
#' @note Typically, end users will not use the `.DefaultDualEndpointBeta()` function.
#' @export
.DefaultDualEndpointBeta <- function() {
  DualEndpointBeta(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    ref_dose = 10,
    use_log_dose = TRUE,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    delta1 = c(0, 5),
    mode = c(1, 15),
    ref_dose_beta = 1000
  )
}

# DualEndpointEmax ----

## class ----

#' `DualEndpointEmax`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DualEndpointEmax`] is the class for the dual endpoint model with `Emax`
#' function for dose-biomarker relationship.
#'
#' @details This class extends the [`DualEndpoint`] class so that the dose-biomarker
#'   relationship \eqn{f(x)} is modelled by a parametric `Emax` function:
#'   \deqn{f(x) = E0 + [(Emax - E0) * (x/x*)]/[ED50 + (x/x*)],}
#'   where \eqn{x*} is a reference dose, \eqn{E0} and \eqn{Emax} are the minimum
#'   and maximum levels for the biomarker, and \eqn{ED50} is the dose achieving
#'   half of the maximum effect \eqn{0.5 * Emax}.
#'   All parameters can currently be assigned uniform distributions or be fixed.
#'
#' @slot E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @slot Emax (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ED50 (`numeric`)\cr either a fixed number or the two uniform
#'   distribution parameters.
#' @slot ref_dose_emax (`positive_number`)\cr the reference dose \eqn{x*} (note
#'   that this is different from the `ref_dose` in the inherited [`DualEndpoint`]
#'   model).
#'
#' @seealso [`DualEndpoint`], [`DualEndpointRW`], [`DualEndpointBeta`].
#'
#' @aliases DualEndpointEmax
#' @export
#'
.DualEndpointEmax <- setClass(
  Class = "DualEndpointEmax",
  slots = c(
    E0 = "numeric",
    Emax = "numeric",
    ED50 = "numeric",
    ref_dose_emax = "numeric"
  ),
  prototype = prototype(
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(0, 500),
    ref_dose_emax = positive_number(1),
    use_fixed = c(
      sigma2W = TRUE,
      rho = TRUE,
      E0 = FALSE,
      Emax = FALSE,
      ED50 = FALSE
    )
  ),
  contains = "DualEndpoint",
  validity = v_model_dual_endpoint_emax
)

## constructor ----

#' @rdname DualEndpointEmax-class
#'
#' @param E0 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param Emax (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ED50 (`numeric`)\cr either a fixed number or the two uniform distribution
#'   parameters.
#' @param ref_dose_emax (`number`)\cr the reference dose \eqn{x*} (strictly
#'   positive number). Note that this is different from the `ref_dose` in the
#'   inherited [`DualEndpoint`] model).
#' @param ... parameters passed to [DualEndpoint()].
#'
#' @export
#' @example examples/Model-class-DualEndpointEmax.R
#'
DualEndpointEmax <- function(E0,
                             Emax,
                             ED50,
                             ref_dose_emax = 1,
                             ...) {
  assert_numeric(E0, min.len = 1, max.len = 2)
  assert_numeric(Emax, min.len = 1, max.len = 2)
  assert_numeric(ED50, min.len = 1, max.len = 2)
  assert_number(ref_dose_emax)

  start <- DualEndpoint(...)

  start@sample <- c(start@sample, "betaW")
  start@datanames_prior <- c("nGrid", "doseGrid")
  ms <- start@modelspecs
  start@modelspecs <- function(from_prior) {
    c(list(ref_dose_emax = ref_dose_emax), ms(from_prior))
  }

  start <- h_model_dual_endpoint_beta(
    param = E0,
    param_name = "E0",
    priormodel = function() {
      E0 ~ dunif(E0_low, E0_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = Emax,
    param_name = "Emax",
    priormodel = function() {
      Emax ~ dunif(Emax_low, Emax_high)
    },
    de = start
  )

  start <- h_model_dual_endpoint_beta(
    param = ED50,
    param_name = "ED50",
    priormodel = function() {
      ED50 ~ dunif(ED50_low, ED50_high)
    },
    de = start
  )

  start@priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      for (i in 1:nGrid) {
        stand_dose_emax[i] <- doseGrid[i] / ref_dose_emax
        betaW[i] <- E0 + (Emax - E0) * stand_dose_emax[i] / (ED50 + stand_dose_emax[i])
      }
    }
  )

  .DualEndpointEmax(
    start,
    E0 = E0,
    Emax = Emax,
    ED50 = ED50,
    ref_dose_emax = positive_number(ref_dose_emax)
  )
}

## default constructor ----

#' @rdname DualEndpointEmax-class
#' @note Typically, end users will not use the `.DefaultDualEndpointEmax()` function.
#' @export
.DefaultDualEndpointEmax <- function() {
  DualEndpointEmax(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    E0 = c(0, 100),
    Emax = c(0, 500),
    ED50 = c(10, 200),
    ref_dose_emax = 1000
  )
}

# ModelPseudo ----

## class ----

#' `ModelPseudo`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelPseudo`] is the parent class for models that express their prior in
#' the form of pseudo data (as if there is some data before the trial starts).
#'
#' @seealso [`GeneralModel`].
#'
#' @aliases ModelPseudo
#' @export
#'
.ModelPseudo <- setClass(
  Class = "ModelPseudo",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname ModelPseudo-class
#' @note Typically, end users will not use the `.DefaultModelPseudo()` function.
#' @export
.DefaultModelPseudo <- function() {
  stop(paste0("Class ModelPseudo should not be instantiated directly.  Please use one of its subclasses instead."))
}

# ModelTox ----

## class ----

#' `ModelTox`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelTox`] is the parent class for DLE (dose-limiting events) models using
#' pseudo data prior. It is dedicated for DLE models or toxicity models that
#' have their prior specified in the form of pseudo data (as if there is some
#' data before the trial starts).
#'
#' The `data` must obey the convention of the [`Data`] class. This refers to any
#' observed DLE responses (`y` in [`Data`]), the dose levels (`x` in [`Data`])
#' at which these responses are observed, all dose levels considered in the
#' study (`doseGrid` in [`Data`]), and finally other specifications in [`Data`]
#' class that can be used to generate prior or posterior modal estimates or
#' samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`Data`)\cr observed data that is used to obtain model parameters
#'   estimates or samples (see details above).
#'
#' @seealso [`ModelEff`].
#'
#' @aliases ModelTox
#' @export
#'
.ModelTox <- setClass(
  Class = "ModelTox",
  slots = c(
    data = "Data"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelTox-class
#' @note Typically, end users will not use the `.DefaultModelTox()` function.
#' @export
.DefaultModelTox <- function() {
  stop(paste0("Class ModelTox should not be instantiated directly.  Please use one of its subclasses instead."))
}

# ModelEff ----

## class ----

#' `ModelEff`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`ModelEff`] is the parent class for efficacy models using pseudo data prior.
#' It is dedicated all efficacy models that have their prior specified in the
#' form of pseudo data (as if there is some data before the trial starts).
#'
#' The `data` must obey the convention of the [`DataDual`] class. This refers to
#' any observed efficacy/biomarker responses (`w` in [`DataDual`]), the dose
#' levels at which these responses are observed (`x` in [`DataDual`]), all dose
#' levels considered in the study (`doseGrid` in [`DataDual`]), and finally
#' other specifications in [`DataDual`] class that can be used to generate prior
#' or posterior modal estimates or samples estimates for model parameter(s).
#' If no responses are observed, at least `doseGrid` has to be specified
#' in `data` for which prior modal estimates or samples can be obtained for
#' model parameters based on the specified pseudo data.
#'
#' @slot data (`DataDual`)\cr observed data that is used to obtain model
#'   parameters estimates or samples (see details above).
#'
#' @seealso [`ModelTox`].
#'
#' @aliases ModelEff
#' @export
#'
.ModelEff <- setClass(
  Class = "ModelEff",
  slots = c(
    data = "DataDual"
  ),
  contains = "ModelPseudo"
)

## default constructor ----

#' @rdname ModelEff-class
#' @note Typically, end users will not use the `.DefaultModelEff()` function.
#' @export
.DefaultModelEff <- function() {
  stop(paste0("Class ModelEff should not be instantiated directly.  Please use one of its subclasses instead."))
}

# LogisticIndepBeta ----

## class ----

#' `LogisticIndepBeta`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`LogisticIndepBeta`] is the class for the two-parameters logistic regression
#' dose-limiting events (DLE) model with prior expressed in form of pseudo data.
#' This model describes the relationship between the binary DLE responses
#' and the dose levels. More specifically, it represents the relationship of the
#' probabilities of the occurrence of a DLE for corresponding dose levels in log
#' scale. This model is specified as
#' \deqn{p(x) = exp(phi1 + phi2 * log(x)) / (1 + exp(phi1 + phi2 * log(x)))}
#' where \eqn{p(x)} is the probability of the occurrence of a DLE at dose \eqn{x}.
#' The two parameters of this model are the intercept \eqn{phi1} and the slope
#' \eqn{phi2}. The `LogisticIndepBeta` inherits all slots from [`ModelTox`] class.
#'
#' In the context of pseudo data, the following three arguments are used,
#' `binDLE`, `DLEdose` and `DLEweights`. The `DLEdose` represents fixed dose
#' levels at which the pseudo DLE responses `binDLE` are observed. `DLEweights`
#' represents total number of subjects treated per each dose level in `DLEdose`.
#' The `binDLE` represents the number of subjects observed with DLE per each
#' dose level in `DLEdose`. Hence, all these three vectors must be of the same
#' length and the order of the elements in any of the vectors `binDLE`,
#' `DLEdose` and `DLEweights` must be kept, so that an element of a given vector
#' corresponds to the elements of the remaining two vectors (see the example for
#' more insight).
#' Finally, since at least two DLE pseudo responses are needed to
#' obtain prior modal estimates (same as the maximum likelihood estimates) for
#' the model parameters, the `binDLE`, `DLEdose` and `DLEweights` must all be
#' vectors of at least length 2.
#'
#' @details The pseudo data can be interpreted as if we obtain some observations
#'   before the trial starts. It can be used to express our prior, i.e. the
#'   initial beliefs for the model parameters. The pseudo data is expressed in
#'   the following way. First, fix at least two dose levels, then ask for experts'
#'   opinion on how many subjects are to be treated at each of these dose levels
#'   and on the number of subjects observed with a DLE. At each dose level, the
#'   number of subjects observed with a DLE, divided by the total number of
#'   subjects treated, is the probability of the occurrence of a DLE at that
#'   particular dose level. The probabilities of the occurrence of a DLE based
#'   on this pseudo data are independent and they follow Beta distributions.
#'   Therefore, the joint prior probability density function of all these
#'   probabilities can be obtained. Hence, by a change of variable, the joint
#'   prior probability density function of the two parameters in this model can
#'   also be obtained. In addition, a conjugate joint prior density function of
#'   the two parameters in the model is used. For details about the form of all
#'   these joint prior and posterior probability density functions, please refer
#'   to Whitehead and Willamson (1998).
#'
#' @slot binDLE (`numeric`)\cr a vector of total numbers of DLE responses.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `DLEdose` and `DLEweights`.
#' @slot DLEdose (`numeric`)\cr a vector of the dose levels corresponding to
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEweights`.
#' @slot DLEweights (`integer`)\cr total number of subjects treated at each of
#'   the pseudo dose level `DLEdose`.
#'   It must be at least of length 2 and the order of its elements must
#'   correspond to values specified in `binDLE` and `DLEdose`.
#' @slot phi1 (`number`)\cr  the intercept of the model. This slot is used in
#'   output to display the resulting prior or posterior modal estimate of the
#'   intercept obtained based on the pseudo data and (if any) observed data/responses.
#' @slot phi2 (`number`)\cr  the slope of the model. This slot is used in output
#'   to display the resulting prior or posterior modal estimate of the slope
#'   obtained based on the pseudo data and (if any) the observed data/responses.
#' @slot Pcov (`matrix`)\cr refers to the 2x2 covariance matrix of the intercept
#'   (\eqn{phi1}) and the slope parameters (\eqn{phi2}) of the model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{phi1} and \eqn{phi2} obtained, based on the
#'   pseudo data and (if any) the observed data and responses. This slot is
#'   needed for internal purposes.
#'
#' @aliases LogisticIndepBeta
#' @export
#'
.LogisticIndepBeta <- setClass(
  Class = "LogisticIndepBeta",
  slots = c(
    binDLE = "numeric",
    DLEdose = "numeric",
    DLEweights = "integer",
    phi1 = "numeric",
    phi2 = "numeric",
    Pcov = "matrix"
  ),
  prototype = prototype(
    binDLE = c(0, 0),
    DLEdose = c(1, 1),
    DLEweights = c(1L, 1L)
  ),
  contains = "ModelTox",
  validity = v_model_logistic_indep_beta
)

## constructor ----

#' @rdname LogisticIndepBeta-class
#'
#' @param binDLE (`numeric`)\cr the number of subjects observed with a DLE, the
#'   pseudo DLE responses, depending on dose levels `DLEdose`.
#'   Elements of `binDLE` must correspond to the elements of `DLEdose` and
#'   `DLEweights`.
#' @param DLEdose (`numeric`)\cr dose levels for the pseudo DLE responses.
#'   Elements of `DLEdose` must correspond to the elements of `binDLE` and
#'   `DLEweights`.
#' @param DLEweights (`numeric`)\cr the total number of subjects treated at each
#'   of the dose levels `DLEdose`, pseudo weights.
#'   Elements of `DLEweights` must correspond to the elements of `binDLE` and
#'   `DLEdose`.
#' @param data (`Data`)\cr the input data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-LogisticIndepBeta.R
#'
LogisticIndepBeta <- function(binDLE,
                              DLEdose,
                              DLEweights,
                              data) {
  assert_numeric(binDLE)
  assert_numeric(DLEdose)
  assert_integerish(DLEweights, lower = 0, any.missing = FALSE)
  assert_class(data, "Data")

  # Combine pseudo and observed data. It can also happen that data@nObs == 0.
  y <- c(binDLE, data@y)
  x <- c(DLEdose, data@x)
  w <- c(DLEweights, rep(1, data@nObs))

  fit_dle <- suppressWarnings(
    glm(y / w ~ log(x), family = binomial(link = "logit"), weights = w)
  )
  phi1 <- coef(fit_dle)[["(Intercept)"]]
  phi2 <- coef(fit_dle)[["log(x)"]]
  Pcov <- vcov(fit_dle)

  .LogisticIndepBeta(
    binDLE = binDLE,
    DLEdose = DLEdose,
    DLEweights = as.integer(DLEweights),
    phi1 = phi1,
    phi2 = phi2,
    Pcov = Pcov,
    data = data
  )
}

## default constructor ----

#' @rdname LogisticIndepBeta-class
#' @note Typically, end users will not use the `.DefaultLogisticIndepBeta()` function.
#' @export
.DefaultLogisticIndepBeta <- function() {
  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3L, 3L),
    DLEdose = c(25, 300),
    data = Data(doseGrid = seq(25, 300, 25))
  )
}


# Effloglog ----

## class ----

#' `Effloglog`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Effloglog`] is the class for the linear log-log efficacy model using pseudo
#' data prior. It describes the relationship between continuous efficacy
#' responses and corresponding dose levels in log-log scale. This efficacy
#' log-log model is given as
#' \deqn{y_i = theta1 + theta2 * log(log(x_i)) + epsilon_i,}
#' where \eqn{y_i} is the efficacy response for subject \eqn{i}, \eqn{x_i} is
#' the dose level treated for subject \eqn{i} and \eqn{epsilon_i} is the random
#' error term of efficacy model at subject \eqn{i}. The error term
#' \eqn{epsilon_i} is a random variable that follows normal distribution with
#' mean \eqn{0} and variance \eqn{nu^{-1}}, which is assumed to be the
#' same for all subjects.
#' There are three parameters in this model, the intercept \eqn{theta1}, the
#' slope \eqn{theta2} and the precision \eqn{nu} of the efficacy responses, also
#' known as the inverse of the variance of the pseudo efficacy responses. It can
#' be a fixed constant or having a gamma distribution. Therefore, a single scalar
#' value or a vector with two positive numbers values must be specified for `nu`
#' slot. If there are some observed efficacy responses available, in the output,
#' `nu` will display the updated value of the precision or the updated values
#' for the parameters of the gamma distribution.
#' The `Effloglog` inherits all slots from [`ModelEff`] class.
#'
#' @details The prior of this model is specified in form of pseudo data. First,
#'   at least two dose levels are fixed. Then, using e.g. experts' opinion, the
#'   efficacy values that correspond to these dose levels can be obtained,
#'   The `eff` and `eff_dose` arguments represent the prior in form of the pseudo
#'   data. The `eff` represents the pseudo efficacy values. The `eff_dose`
#'   represents the dose levels at which these pseudo efficacy values are
#'   observed. Hence, the positions of the elements specified in `eff` and
#'   `eff_dose` must correspond to each other between these vectors.
#'   Since at least 2 pseudo efficacy values are needed to obtain modal
#'   estimates of the intercept and slope parameters, both `eff` and `eff_dose`
#'   must be vectors of length at least 2.
#'
#'   The joint prior distribution of the intercept \eqn{theta1} and the slope
#'   \eqn{theta2} of this model follows bivariate normal distribution with mean
#'   \eqn{mu} and covariance matrix \eqn{(nu * Q)^{-1}}.
#'   The mean \eqn{mu} is a \eqn{2 x 1} column vector that contains the prior
#'   modal estimates of the intercept and the slope.
#'   Scalar \eqn{nu} is the precision of the pseudo efficacy responses and
#'   \eqn{Q} is the prior or posterior (given that observed, no DLT data is
#'   available) precision matrix.
#'   It is specified as \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a
#'   design matrix that is based on pseudo dose levels only, and \eqn{X} is a
#'   design matrix that is based on dose levels corresponding to the no DLT
#'   efficacy responses observed only (if any).
#'   Hence, the \eqn{X0} (or \eqn{X}) will be of size \eqn{r x 2}, if
#'   there are \eqn{r >= 2} pseudo efficacy responses specified (or
#'   if there are \eqn{r} no DLT efficacy responses observed in the `data`).
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot nu (`numeric`)\cr parameter of the prior precision of pseudo efficacy
#'   responses. This is either a fixed value or a named vector with two positive
#'   numbers, the shape (`a`), and the rate (`b`) parameters for the gamma
#'   distribution.
#' @slot use_fixed (`flag`)\cr indicates whether `nu` specified is a fixed value
#'   or a vector with two parameters for gamma distribution. This slot is for
#'   internal purposes only and must not be used by the user.
#' @slot theta1 (`number`)\cr the intercept in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot theta2 (`number`)\cr the slope in this efficacy log-log model. This
#'   slot is used in output to display the resulting prior or posterior modal
#'   estimates obtained based on the pseudo and observed (if any) data.
#' @slot Pcov (`matrix`)\cr refers to the \eqn{2 x 2} covariance matrix of the
#'   estimators of the intercept \eqn{theta1} and the slope \eqn{theta2}
#'   parameters in this model.
#'   This is used in output to display the resulting prior and posterior
#'   covariance matrix of \eqn{theta1} and \eqn{theta2} obtained, based on the
#'   pseudo and observed (if any) data. This slot is needed for internal purposes.
#' @slot X (`matrix`)\cr is the design matrix that is based on either the pseudo
#'   dose levels or observed dose levels (without DLT). This is used
#'   in the output to display the design matrix for the pseudo or the observed
#'   efficacy responses.
#' @slot Y (`numeric`)\cr is a vector that either contains the pseudo efficacy
#'   responses or observed efficacy responses (without DLT).
#' @slot mu (`numeric`)\cr a vector of the prior or the posterior modal estimates
#'   of the intercept (\eqn{theta1}) and the slope (\eqn{theta2}).
#'   This slot is used in output to display as the mean of the prior or posterior
#'   bivariate normal distribution for \eqn{theta1} and \eqn{theta2}.
#' @slot Q (`matrix`)\cr is the prior or posterior (given that observed, no DLT
#'   data is available) precision matrix. It is specified as
#'   \eqn{Q = X0^T * X0 + X^T * X}, where \eqn{X0} is a design matrix that is
#'   based on pseudo dose levels only, and \eqn{X} is a design matrix that is
#'   based on dose levels corresponding to the observed, no DLT efficacy values
#'   only (if any).
#' @slot const (`number`)\cr a non-negative number (default to 0), leading to the
#'   model form described above. In general, the model has the form
#'   \eqn{y_i = theta1 + theta2 * log(log(x_i + const)) + epsilon_i}, such that
#'   dose levels greater than \eqn{1 - const} can be considered as described in
#'   Yeung et al. (2015).
#'
#' @aliases Effloglog
#' @export
#'
.Effloglog <- setClass(
  Class = "Effloglog",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    nu = "numeric",
    use_fixed = "logical",
    theta1 = "numeric",
    theta2 = "numeric",
    Pcov = "matrix",
    X = "matrix",
    Y = "numeric",
    mu = "numeric",
    Q = "matrix",
    const = "numeric"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    nu = 1 / 0.025,
    use_fixed = TRUE,
    const = 0
  ),
  contains = "ModelEff",
  validity = v_model_eff_log_log
)

## constructor ----

#' @rdname Effloglog-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param nu (`numeric`)\cr the precision (inverse of the variance) of the
#'   efficacy responses. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   gamma distribution.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#' @param const (`number`)\cr the constant value added to the dose level when
#'   the dose level value is less than or equal to 1 and a special form of the
#'   linear log-log has to applied (Yeung et al. (2015).).
#'
#' @export
#' @example examples/Model-class-Effloglog.R
#'
Effloglog <- function(eff,
                      eff_dose,
                      nu,
                      data,
                      const = 0) {
  assert_numeric(eff)
  assert_numeric(eff_dose, len = length(eff))
  assert_numeric(nu, min.len = 1, max.len = 2)
  assert_class(data, "Data")
  assert_number(const, finite = TRUE)

  use_fixed <- length(nu) == 1L

  eff_dose <- eff_dose + const
  # Get observed efficacy data without DLT (if any).
  eff_obsrv_w_x <- getEff(data, no_dlt = TRUE)
  eff_obsrv <- eff_obsrv_w_x$w_no_dlt
  eff_obsrv_dose <- eff_obsrv_w_x$x_no_dlt + const

  # Fit pseudo and observed (if any) efficacy.
  w <- c(eff, eff_obsrv)
  x <- c(eff_dose, eff_obsrv_dose)
  fit_eff <- suppressWarnings(lm(w ~ log(log(x))))
  X <- model.matrix(fit_eff)
  Y <- w
  mu <- coef(fit_eff) # This is [theta1, theta2]^T est.
  Q <- crossprod(X)
  Pcov <- vcov(fit_eff)

  nobs_no_dlt <- length(eff_obsrv)
  if (nobs_no_dlt > 0L) { # Observed data available.
    # Set X, Y to observed data only.
    X <- model.matrix(fit_eff)[-seq_along(eff), ]
    Y <- eff_obsrv

    fit_eff0 <- lm(eff ~ log(log(eff_dose))) # Pseudo only.
    X0 <- model.matrix(fit_eff0)
    mu0 <- coef(fit_eff0)
    Q0 <- crossprod(X0)
    # Note that mu = (Q0 + X^T * X)^{-1} * (Q0 * mu0 + X^T * X * (X^T * X)^{-1} X^T * Y),
    # given that (X^T * X) is invertible and X, Y, mu0, Q0, are specified in this else block.
    if (!use_fixed) {
      nu["a"] <- nu["a"] + (nobs_no_dlt) / 2
      nu["b"] <- nu["b"] + (crossprod(Y) + t(mu0) %*% Q0 %*% mu0 - t(mu) %*% Q %*% mu) / 2
    }
  }

  .Effloglog(
    eff = eff,
    eff_dose = eff_dose,
    nu = nu,
    use_fixed = use_fixed,
    theta1 = mu[["(Intercept)"]],
    theta2 = mu[["log(log(x))"]],
    Pcov = Pcov,
    X = X,
    Y = Y,
    mu = as.vector(mu),
    Q = Q,
    const = const,
    data = data
  )
}

## default constructor ----

#' @rdname Effloglog-class
#' @note Typically, end users will not use the `.DefaultEffloglog()` function.
#' @export
.DefaultEffloglog <- function() {
  emptydata <- DataDual(doseGrid = seq(25, 300, 25), placebo = FALSE)

  my_data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = emptydata@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = my_data
  )
}

# EffFlexi ----

## class ----

#' `EffFlexi`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`EffFlexi`] is the class for the efficacy model in flexible form of prior
#' expressed in form of pseudo data. In this class, a flexible form is used to
#' describe the relationship between the efficacy responses and the dose levels
#' and it is specified as
#' \deqn{(W | betaW, sigma2W) ~ Normal(X * betaW, sigma2W * I),}
#' where \eqn{W} is a vector of the efficacy responses, \eqn{betaW} is a column
#' vector of the mean efficacy responses for all dose levels, and \eqn{X} is
#' the design matrix with entries \eqn{I_i,j} that are equal to 1 if subject
#' \eqn{i} is allocated to dose \eqn{j}, and \eqn{0} otherwise. The \eqn{sigma2W}
#' is the variance of the efficacy responses which can be either a fixed number
#' or a number from an inverse gamma distribution.
#' This flexible form aims to capture different shapes of the dose-efficacy
#' curve. In addition, the first (RW1) or second order (RW2) random walk model
#' can be used for smoothing data. That is the random walk model is used to model
#' the first or the second order differences of the mean efficacy responses to
#' its neighboring dose levels of their mean efficacy responses.
#'
#' The RW1 model is given as
#' \deqn{betaW_j - betaW_j-1) ~ Normal(0, sigma2betaW),}
#' and for RW2 as
#' \deqn{betaW_j-2 - 2 * betaW_j-1 + beta_j ~ Normal(0, sigma2betaW),}
#' where \eqn{betaW_j} is the vector of mean efficacy responses at dose j, and
#' the \eqn{sigma2betaW} is the prior variance which can be either a fixed
#' number or a number from an inverse gamma distribution.
#'
#' The `eff` and `eff_dose` are the pseudo efficacy responses and dose levels at
#' which these pseudo efficacy responses are observed. Both, `eff` and `eff_dose`
#' must be vectors of length at least 2. The positions of the elements specified
#' in `eff` and `eff_dose` must correspond to each other between these vectors.
#'
#' @details This model will output the updated value or the updated values of the
#'   parameters of the inverse gamma distributions for \eqn{sigma2W} and
#'   \eqn{sigma2betaW}. The `EffFlexi` inherits all slots from [`ModelEff`] class.
#'
#' @slot eff (`numeric`)\cr the pseudo efficacy responses. Each element here
#'   must represent responses treated based on one subject.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff_dose`.
#' @slot eff_dose (`numeric`)\cr the pseudo efficacy dose levels at which the
#'   pseudo efficacy responses are observed.
#'   It must be a vector of length at least 2 and the order of its elements must
#'   correspond to values specified in `eff`.
#' @slot sigma2W (`numeric`)\cr the prior variance of the flexible efficacy form.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the gamma distribution.
#' @slot sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   for the mean efficacy responses. This is either a fixed value or a named
#'   vector with two positive numbers, the shape (`a`), and the rate (`b`)
#'   parameters for the gamma distribution.
#' @slot use_fixed (`logical`)\cr indicates whether a fixed value for
#'   `sigma2W` and `sigma2betaW` (for each parameter separately) is used or not.
#'   This slot is needed for internal purposes and must not be touched by the user.
#' @slot rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @slot X (`matrix`)\cr the design matrix for the efficacy responses. It is
#'   based on both the pseudo and the observed efficacy responses.
#' @slot RW (`matrix`)\cr the difference matrix for the random walk model. This
#'   slot is needed for internal purposes and must not be used by the user.
#' @slot RW_rank (`integer`)\cr is the rank of the difference matrix. This
#'   slot is needed for internal purposes and must not be used by the user.
#'
#' @aliases EffFlexi
#' @export
#'
.EffFlexi <- setClass(
  Class = "EffFlexi",
  slots = c(
    eff = "numeric",
    eff_dose = "numeric",
    sigma2W = "numeric",
    sigma2betaW = "numeric",
    use_fixed = "logical",
    rw1 = "logical",
    X = "matrix",
    RW = "matrix",
    RW_rank = "integer"
  ),
  prototype = prototype(
    eff = c(0, 0),
    eff_dose = c(1, 1),
    sigma2W = 0.025,
    sigma2betaW = 1,
    rw1 = TRUE,
    use_fixed = c(sigma2W = TRUE, sigma2betaW = TRUE)
  ),
  contains = "ModelEff",
  validity = v_model_eff_flexi
)

## constructor ----

#' @rdname EffFlexi-class
#'
#' @param eff (`numeric`)\cr the pseudo efficacy responses.
#'   Elements of `eff` must correspond to the elements of `eff_dose`.
#' @param eff_dose (`numeric`)\cr dose levels that correspond to pseudo efficacy
#'   responses in `eff`.
#' @param sigma2W (`numeric`)\cr the prior variance of the efficacy responses.
#'   This is either a fixed value or a named vector with two positive numbers,
#'   the shape (`a`), and the rate (`b`) parameters for the inverse gamma
#'   distribution.
#' @param sigma2betaW (`numeric`)\cr the prior variance of the random walk model
#'   used for smoothing. This is either a fixed value or a named vector with two
#'   positive numbers, the shape (`a`), and the rate (`b`) parameters for the
#'   inverse gamma distribution.
#' @param rw1 (`flag`)\cr used for smoothing data for this efficacy model. If it
#'   is `TRUE`, the first-order random walk model is used for the mean efficacy
#'   responses. Otherwise, the random walk of second order is used.
#' @param data (`DataDual`)\cr observed data to update estimates of the model
#'   parameters.
#'
#' @export
#' @example examples/Model-class-EffFlexi.R
#'
EffFlexi <- function(eff,
                     eff_dose,
                     sigma2W,
                     sigma2betaW,
                     rw1 = TRUE,
                     data) {
  assert_numeric(eff)
  assert_numeric(eff_dose)
  assert_numeric(sigma2W, min.len = 1, max.len = 2)
  assert_numeric(sigma2betaW, min.len = 1, max.len = 2)
  assert_flag(rw1)
  assert_class(data, "DataDual")

  use_fixed <- c(
    sigma2W = test_number(sigma2W),
    sigma2betaW = test_number(sigma2betaW)
  )

  x <- c(eff_dose, getEff(data, no_dlt = TRUE)$x_no_dlt)
  x_level <- match_within_tolerance(x, data@doseGrid)
  X <- model.matrix(~ -1L + factor(x_level, levels = seq_len(data@nGrid)))
  X <- matrix(as.integer(X), ncol = ncol(X)) # To remove some obsolete attributes.

  # Set up the random walk penalty matrix and its rank.
  # D1: difference matrix of order 1.
  D1 <- cbind(0, diag(data@nGrid - 1)) - cbind(diag(data@nGrid - 1), 0)
  if (rw1) { # the rank-deficient prior precision for the RW1 prior.
    RW <- crossprod(D1)
    RW_rank <- data@nGrid - 1L # rank = dimension - 1. # nolintr
  } else { # Second-order difference.
    D2 <- D1[-1, -1] %*% D1
    RW <- crossprod(D2)
    RW_rank <- data@nGrid - 2L # nolintr
  }

  .EffFlexi(
    eff = eff,
    eff_dose = eff_dose,
    sigma2W = sigma2W,
    sigma2betaW = sigma2betaW,
    use_fixed = use_fixed,
    rw1 = rw1,
    X = X,
    RW = RW,
    RW_rank = RW_rank,
    data = data
  )
}

## default constructor ----

#' @rdname EffFlexi-class
#' @note Typically, end users will not use the `.DefaultEffFlexi()` function.
#' @export
.DefaultEffFlexi <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))
  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = empty_data
  )

  data <- DataDual(
    x = c(25, 50, 50, 75, 100, 100, 225, 300),
    y = c(0, 0, 0, 0, 1, 1, 1, 1),
    w = c(0.31, 0.42, 0.59, 0.45, 0.6, 0.7, 0.6, 0.52),
    doseGrid = empty_data@doseGrid,
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 2, 3, 4, 4, 5, 6))
  )

  EffFlexi(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    sigma2W = c(a = 0.1, b = 0.1),
    sigma2betaW = c(a = 20, b = 50),
    rw1 = FALSE,
    data = data
  )
}

# DALogisticLogNormal ----

## class ----

#' `DALogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DALogisticLogNormal`] is the class for the logistic model with bivariate
#' (log) normal prior and data augmentation. This class inherits from the
#' [`LogisticLogNormal`] class.
#'
#' @note We still need to include here formula for the lambda prior.
#'
#' @slot npiece (`number`)\cr the number of pieces in the `PEM`.
#' @slot l (`numeric`)\cr a vector used in the lambda prior.
#' @slot c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @slot cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormal`], [`LogisticLogNormal`].
#'
#' @aliases DALogisticLogNormal
#' @export
#'
.DALogisticLogNormal <- setClass(
  Class = "DALogisticLogNormal",
  slots = c(
    npiece = "integer",
    l = "numeric",
    c_par = "numeric",
    cond_pem = "logical"
  ),
  prototype = prototype(
    npiece = 3L,
    l = 0.5,
    c_par = 2,
    cond_pem = TRUE
  ),
  contains = "LogisticLogNormal",
  validity = v_model_da_logistic_log_normal
)

## constructor ----

#' @rdname DALogisticLogNormal-class
#'
#' @param npiece (`number`)\cr the number of pieces in the `PEM`.
#' @param l (`numeric`)\cr a vector used in the lambda prior.
#' @param c_par (`numeric`)\cr a parameter used in the lambda prior; according to
#'   Liu's paper, `c_par = 2` is recommended.
#' @param cond_pem (`flag`)\cr is a conditional piecewise-exponential model used?
#'   (default). Otherwise an unconditional model is used.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-DALogisticLogNormal.R
#'
DALogisticLogNormal <- function(npiece = 3,
                                l,
                                c_par = 2,
                                cond_pem = TRUE,
                                ...) {
  assert_flag(cond_pem)

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      # Part I: describe the logistic model of DLTs vs dose.
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # Part II: describe the piecewise exponential.
      # Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      indx[i] <- 1 - step(Tmax - u[i] - eps) * (1 - y[i])

      for  (j in 1:npiece) {
        # When not censored, i.e DLT!=NA & t[i]=u[i];
        # if t[i]<h[j], d[i,j]=0;
        # if h[j]<t[i]=<h[j+1], d[i,j]=1
        # if h[j+1]<t[i], d[i,j]=0
        # When censored t[i]>u[i] -> d[i,j]=0
        d[i, j] <- y[i] * step(u[i] - h[j] - eps) * step(h[j + 1] - u[i])

        # DLT free survival(time) for patient i in interval I(j);
        # if t[i]<h[j], s[i,j]=0;
        # if h[j]<t[i]<=h[j+1], s[i,j]=t[i]-h[j]
        # if h[j+1]<=t[i], s[i,j]=h[j+1]-h[j]
        s[i, j] <- min(u[i] - h[j], h[j + 1] - h[j]) * step(u[i] - h[j])

        # piecewise exponential hazard rate lambda[j];
        mu_u[i, j] <- lambda[j] * s[i, j]
        mu[i, j] <- d[i, j] * log(lambda[j]) - y[i] * mu_u[i, j]
      }

      # The likelihood function.
      L_obs[i] <- exp(sum(mu[i, ])) * pow(p[i] / A, y[i]) * pow(1 - p[i], 1 - y[i]) # Not censored. # nolintr
      L_cnsr[i] <- 1 - p[i] * (1 - exp(-sum(mu_u[i, ]))) / A # Censored. # nolintr
      L[i] <- pow(L_obs[i], indx[i]) * pow(L_cnsr[i], 1 - indx[i])

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  priormodel <- h_jags_join_models(
    start@priormodel,
    function() {
      g_beta <- 1 / c_par
      for  (j in 1:npiece) {
        g_alpha[j] <- l[j] / c_par
        lambda[j] ~ dgamma(g_alpha[j], g_beta)
        mu_T[j] <- lambda[j] * (h[j + 1] - h[j]) # nolintr
      }
      # If cond = 1, then conditional PEM is used and A is defined as
      # the probability to have DLT, i.e. t<T, otherwise
      # cond = 0 and A is just 1 (so no impact in likelihood).
      A <- cond * (1 - exp(-sum(mu_T))) + (1 - cond)
    }
  )

  modelspecs <- function(nObs, Tmax, from_prior) {
    ms <- list(
      prec = start@params@prec,
      mean = start@params@mean,
      npiece = npiece,
      l = l,
      c_par = c_par,
      h = seq(from = 0L, to = Tmax, length = npiece + 1),
      cond = as.integer(cond_pem)
    )
    if (!from_prior) {
      ms <- c(list(ref_dose = start@ref_dose, zeros = rep(0, nObs), eps = 1e-10, cadj = 1e10), ms)
    }
    ms
  }

  assert_integerish(npiece, lower = 1)

  .DALogisticLogNormal(
    start,
    npiece = as.integer(npiece),
    l = l,
    c_par = c_par,
    cond_pem = cond_pem,
    datamodel = datamodel,
    priormodel = priormodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x", "u", "Tmax"),
    sample = c("alpha0", "alpha1", "lambda")
  )
}

## default constructor ----

#' @rdname DALogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultDALogisticLogNormal()` function.
#' @export
.DefaultDALogisticLogNormal <- function() {
  npiece <- 10
  Tmax <- 60

  lambda_prior <- function(k) {
    npiece / (Tmax * (npiece - k + 0.5))
  }

  DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece,
    l = as.numeric(t(apply(as.matrix(c(1:npiece), 1, npiece), 2, lambda_prior))),
    c_par = 2
  )
}

# TITELogisticLogNormal ----

## class ----

#' `TITELogisticLogNormal`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TITELogisticLogNormal`] is the class for TITE-CRM based on a logistic
#' regression model using a bivariate normal prior on the intercept and log
#' slope parameters.
#'
#' This class inherits from the [`LogisticLogNormal`].
#'
#' @slot weight_method (`string`)\cr the weight function method: either linear
#'   or adaptive. This was used in Liu, Yin and Yuan's paper.
#'
#' @seealso [`DALogisticLogNormal`].
#'
#' @aliases TITELogisticLogNormal
#' @export
#'
.TITELogisticLogNormal <- setClass(
  Class = "TITELogisticLogNormal",
  slots = c(weight_method = "character"),
  prototype = prototype(weight_method = "linear"),
  contains = "LogisticLogNormal",
  validity = v_model_tite_logistic_log_normal
)

## constructor ----

#' @rdname TITELogisticLogNormal-class
#'
#' @param weight_method (`string`)\cr the weight function method: either linear
#'   or adaptive. This was used in Liu, Yin and Yuan's paper.
#' @inheritDotParams LogisticLogNormal
#'
#' @export
#' @example examples/Model-class-TITELogisticLogNormal.R
#'
TITELogisticLogNormal <- function(weight_method = "linear",
                                  ...) {
  assert_character(weight_method, min.len = 1L, max.len = 2L, any.missing = FALSE)

  start <- LogisticLogNormal(...)

  datamodel <- function() {
    for (i in 1:nObs) {
      logit(p[i]) <- alpha0 + alpha1 * log(x[i] / ref_dose)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing;
      # when indx=0 -> censored, i.e u<T and event=0;
      # when indx=1 -> not censored, i.e. u>=T or event=1;
      L[i] <- pow(p[i], y[i]) * pow((1 - w[i] * p[i]), (1 - y[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(prec = start@params@prec, mean = start@params@mean)
    # Calculate weights `w` based on the input data.
    if (!from_prior && nObs > 0L) {
      if (weight_method == "linear") {
        w <- u / Tmax
      } else if (weight_method == "adaptive") {
        nDLT <- sum(y)
        if (nDLT > 0) {
          u_dlt <- sort(u[y == 1])
          w <- sapply(u, function(u_i) {
            m <- sum(u_i >= u_dlt)
            w_i <- if (m == 0) {
              u_i / u_dlt[1]
            } else if (m < nDLT) {
              m + (u_i - u_dlt[m]) / (u_dlt[m + 1] - u_dlt[m])
            } else { # m == nDLT. nolintr
              m + (u_i - u_dlt[m]) / (Tmax + 0.00000001 - u_dlt[m])
            }
            w_i / (nDLT + 1)
          })
        } else {
          w <- u / Tmax
        }
      }
      w[y == 1] <- 1
      w[u == Tmax] <- 1

      ms <- c(list(ref_dose = start@ref_dose, zeros = rep(0, nObs), cadj = 1e10, w = w), ms)
    }
    ms
  }

  .TITELogisticLogNormal(
    start,
    weight_method = weight_method,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "y", "x")
  )
}

## default constructor ----

#' @rdname TITELogisticLogNormal-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultTITELogisticLogNormal <- function() {
  TITELogisticLogNormal(
    mean = c(0, 1),
    cov = diag(2),
    ref_dose = 1,
    weight_method = "linear"
  )
}

# OneParLogNormalPrior ----

## class ----

#' `OneParLogNormalPrior`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`OneParLogNormalPrior`] is the class for a standard CRM with a normal prior on
#' the log power parameter for the skeleton prior probabilities.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @seealso [`ModelLogNormal`].
#'
#' @aliases OneParLogNormalPrior
#' @export
#'
.OneParLogNormalPrior <- setClass(
  Class = "OneParLogNormalPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    sigma2 = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_normal_prior
)

## constructor ----

#' @rdname OneParLogNormalPrior-class
#'
#' @param skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param sigma2 (`number`)\cr prior variance of log power parameter alpha.
#'
#' @export
#' @example examples/Model-class-OneParLogNormalPrior.R
#'
OneParLogNormalPrior <- function(skel_probs,
                                 dose_grid,
                                 sigma2) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(dose_grid, len = length(skel_probs), any.missing = FALSE, unique = TRUE, sorted = TRUE)

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParLogNormalPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    sigma2 = sigma2,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^exp(alpha)
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      alpha ~ dnorm(0, 1 / sigma2)
    },
    modelspecs = function(from_prior) {
      ms <- list(sigma2 = sigma2)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(alpha = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "alpha"
  )
}

## default constructor ----

#' @rdname OneParLogNormalPrior-class
#' @return an instance of the `OneParLogNormalPrior` class
#' @export
.DefaultOneParLogNormalPrior <- function() {
  OneParLogNormalPrior(
    skel_probs = seq(from = 0.1, to = 0.9, length = 5),
    dose_grid = 1:5,
    sigma2 = 2
  )
}

# OneParExpPrior ----

## class ----

#' `OneParExpPrior`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`OneParExpPrior`] is the class for a standard CRM with an exponential prior
#' on the power parameter for the skeleton prior probabilities. It is an
#' implementation of a version of the one-parameter CRM (O’Quigley et al. 1990).
#'
#' @note Typically, end users will not use the `.DefaultOneparExpPrior()` function.
#'
#' @slot skel_fun (`function`)\cr function to calculate the prior DLT probabilities.
#' @slot skel_fun_inv (`function`)\cr inverse function of `skel_fun`.
#' @slot skel_probs (`numeric`)\cr skeleton prior probabilities. This is a vector
#'   of unique and sorted probability values between 0 and 1.
#' @slot lambda (`number`)\cr rate parameter of prior exponential distribution
#'   for theta.
#'
#' @aliases OneParExpPrior
#' @export
#'
.OneParExpPrior <- setClass(
  Class = "OneParExpPrior",
  slots = c(
    skel_fun = "function",
    skel_fun_inv = "function",
    skel_probs = "numeric",
    lambda = "numeric"
  ),
  contains = "GeneralModel",
  validity = v_model_one_par_exp_prior
)

## constructor ----

#' @rdname OneParExpPrior-class
#'
#' @param skel_probs see slot definition.
#' @param dose_grid (`numeric`)\cr dose grid. It must be must be a sorted vector
#'   of the same length as `skel_probs`.
#' @param lambda see slot definition.
#'
#' @export
#' @example examples/Model-class-OneParExpPrior.R
#'
OneParExpPrior <- function(skel_probs,
                           dose_grid,
                           lambda) {
  assert_probabilities(skel_probs, unique = TRUE, sorted = TRUE) # So that skel_fun_inv exists.
  assert_numeric(dose_grid, len = length(skel_probs), any.missing = FALSE, unique = TRUE, sorted = TRUE)

  skel_fun <- approxfun(x = dose_grid, y = skel_probs, rule = 2)
  skel_fun_inv <- approxfun(x = skel_probs, y = dose_grid, rule = 2)

  .OneParExpPrior(
    skel_fun = skel_fun,
    skel_fun_inv = skel_fun_inv,
    skel_probs = skel_probs,
    lambda = lambda,
    datamodel = function() {
      for (i in 1:nObs) {
        p[i] <- skel_probs[xLevel[i]]^theta
        y[i] ~ dbern(p[i])
      }
    },
    priormodel = function() {
      theta ~ dexp(lambda)
    },
    modelspecs = function(from_prior) {
      ms <- list(lambda = lambda)
      if (!from_prior) {
        ms$skel_probs <- skel_probs
      }
      ms
    },
    init = function() {
      list(theta = 1)
    },
    datanames = c("nObs", "y", "xLevel"),
    sample = "theta"
  )
}

## default constructor ----

#' @rdname OneParExpPrior-class
#' @note Typically, end users will not use the `.DefaultOneParLogNormalPrior()` function.
#' @export
.DefaultOneParExpPrior <- function() {
  OneParExpPrior(
    skel_probs = c(0.1, 0.3, 0.5, 0.7, 0.9),
    dose_grid = 1:5,
    lambda = 2
  )
}

# FractionalCRM ----

## class ----

#' `FractionalCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`FractionalCRM`] is the class for a fractional CRM model based on a one
#' parameter CRM (with normal prior on the log-power parameter) as well as
#' Kaplan-Meier based estimation of the conditional probability to experience a
#' DLT for non-complete observations.
#'
#' This fractional CRM model follows the paper and code by Guosheng Yin et al.
#'
#' @seealso [`TITELogisticLogNormal`].
#'
#' @aliases FractionalCRM
#' @export
#'
.FractionalCRM <- setClass(
  Class = "FractionalCRM",
  contains = "OneParLogNormalPrior"
)

## constructor ----

#' @rdname FractionalCRM-class
#'
#' @inheritDotParams OneParLogNormalPrior
#'
#' @export
#' @example examples/Model-class-FractionalCRM.R
#'
FractionalCRM <- function(...) {
  start <- OneParLogNormalPrior(...)

  # This is adapted from the TITELogisticLogNormal class.
  datamodel <- function() {
    for (i in 1:nObs) {
      p[i] <- skel_probs[xLevel[i]]^exp(alpha)

      # The piecewise exponential likelihood. Notice that:
      # when y=1             -> DLT=1 and u=<T;
      # when y=0 & T<t (u=T) -> DLT=0;
      # when y=0 & T>t (u<T) -> DLT=NA/missing.
      # Therefore, `yhat` is used instead of `y` for the likelihood f. (see `modelspecs`).
      L[i] <- pow(p[i], yhat[i]) * pow((1 - p[i]), (1 - yhat[i]))

      # Apply zero trick in JAGS.
      phi[i] <- -log(L[i]) + cadj
      zeros[i] ~ dpois(phi[i])
    }
  }

  modelspecs <- function(nObs, u, Tmax, y, from_prior) {
    ms <- list(sigma2 = start@sigma2)
    if (!from_prior) {
      # Calculate fractional contribution `yhat`
      # based on the input data using the Kaplan-Meier method.
      yhat <- if (nObs > 0) {
        km <- survival::survfit(survival::Surv(u, y) ~ 1)
        s_tau <- tail(km$surv[km$time <= Tmax], 1) # Survival probability = S(Tmax).
        ifelse(
          u < Tmax & y == 0L, # Within the assessment window and so far no DLT.
          yes = 1 - s_tau / sapply(u, function(u_i) tail(km$surv[km$time <= u_i], 1)),
          no = y
        )
      } else {
        1L
      }
      ms <- c(
        list(skel_probs = start@skel_probs, zeros = rep(0, nObs), cadj = 1e10, yhat = yhat),
        ms
      )
    }
    ms
  }

  .FractionalCRM(
    start,
    datamodel = datamodel,
    modelspecs = modelspecs,
    datanames = c("nObs", "xLevel")
  )
}

## default constructor ----

#' @rdname FractionalCRM-class
#' @note Typically, end users will not use the `.DefaultTITELogisticLogNormal()` function.
#' @export
.DefaultFractionalCRM <- function() {
  FractionalCRM(
    skel_probs = c(0.1, 0.2, 0.3, 0.4),
    dose_grid = c(10, 30, 50, 100),
    sigma2 = 2
  )
}

## class ----

#' `LogisticLogNormalOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`LogisticLogNormalOrdinal`] is the class for a logistic lognormal CRM model
#' using an ordinal toxicity scale.
#'
#' @aliases LogisticLogNormalOrdinal
#' @export
.LogisticLogNormalOrdinal <- setClass(
  Class = "LogisticLogNormalOrdinal",
  contains = "ModelLogNormal",
  validity = v_logisticlognormalordinal
)

## constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @inheritParams ModelLogNormal
#' @export
#' @example examples/Model-class-LogisticLogNormalOrdinal.R
LogisticLogNormalOrdinal <- function(mean, cov, ref_dose) {
  params <- ModelParamsNormal(mean, cov)
  .LogisticLogNormalOrdinal(
    params = params,
    ref_dose = positive_number(ref_dose),
    priormodel = function() {
      alpha[1] ~ dnorm(mean[1], prec[1, 1])
      for (i in 2:(k - 1)) {
        alpha[i] ~ dnorm(mean[i], prec[i, i]) %_% T(, alpha[i - 1])
      }
      gamma ~ dnorm(mean[k], prec[k, k])
      beta <- exp(gamma)
    },
    datamodel = function() {
      for (i in 1:nObs) {
        xhat[i] <- log(x[i] / ref_dose)
        for (j in 1:(k - 1)) {
          z[i, j] <- alpha[j] + beta * xhat[i]
          p[i, j] <- exp(z[i, j]) / (1 + exp(z[i, j]))
          tox[i, j] ~ dbern(p[i, j])
        }
      }
    },
    modelspecs = function(y, from_prior) {
      ms <- list(
        mean = params@mean,
        prec = params@prec,
        k = length(mean),
        tox = array(dim = c(length(y), length(mean) - 1))
      )
      if (!from_prior) {
        for (i in seq_along(y)) {
          for (j in 1:(ms$k - 1)) {
            ms$tox[i, j] <- y[i] >= j
          }
        }
        ms$ref_dose <- ref_dose
      }
      ms
    },
    init = function() {
      list(alpha = sapply(1:(length(mean) - 1), function(x) -(x + 1)), gamma = 1)
    },
    datanames = c("nObs", "y", "x"),
    # Need to provide JAGS column names here
    sample = c(paste0("alpha[", 1:(length(mean) - 1), "]"), "beta")
  )
}

## default constructor ----

#' @rdname LogisticLogNormalOrdinal-class
#' @note Typically, end users will not use the `.DefaultLogisticLogNormalOrdinal()` function.
#' @export
.DefaultLogisticLogNormalOrdinal <- function() {
  LogisticLogNormalOrdinal(
    mean = c(-3, -4, 1),
    cov = diag(c(3, 4, 1)),
    ref_dose = 50
  )
}

#' @include helpers.R
#' @include Rules-validity.R
#' @include CrmPackClass-class.R
NULL

# NextBest ----

## class ----

#' `NextBest`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBest`] is a virtual class for finding next best dose, from which all
#' other specific next best dose classes inherit.
#'
#' @seealso [`NextBestMTD`], [`NextBestNCRM`], [`NextBestDualEndpoint`],
#'   [`NextBestThreePlusThree`], [`NextBestDualEndpoint`], [`NextBestMinDist`],
#'   [`NextBestInfTheory`], [`NextBestTD`], [`NextBestTDsamples`],
#'   [`NextBestMaxGain`], [`NextBestMaxGainSamples`].
#'
#' @aliases NextBest
#' @export
#'
setClass(
  Class = "NextBest",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname NextBest-class
#' @note Typically, end users will not use the `DefaultNextBest()` function.
#' @export
.DefaultNextBest <- function() {
  stop(paste0("Class NextBest should not be instantiated directly.  Please use one of its subclasses instead."))
}


# NextBestMTD ----

## class ----

#' `NextBestMTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMTD`] is the class for next best dose based on MTD estimate.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot derive (`function`)\cr a function which derives the final next best MTD
#'   estimate, based on vector of posterior MTD samples. It must therefore accept
#'   one and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMTD
#' @export
#'
.NextBestMTD <- setClass(
  Class = "NextBestMTD",
  slots = c(
    target = "numeric",
    derive = "function"
  ),
  prototype = prototype(
    target = 0.3,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.3)
    }
  ),
  contains = "NextBest",
  validity = v_next_best_mtd
)

## constructor ----

#' @rdname NextBestMTD-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMTD.R
#'
NextBestMTD <- function(target, derive) {
  .NextBestMTD(
    target = target,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestMTD-class
#' @note Typically, end users will not use the `.DefaultNextBestMTD()` function.
#' @export
.DefaultNextBestMTD <- function() {
  NextBestMTD(
    target = 0.33,
    derive = function(mtd_samples) {
      quantile(mtd_samples, probs = 0.25)
    }
  )
}

# NextBestNCRM ----

## class ----

#' `NextBestNCRM`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRM`] is the class for next best dose that finds the next dose
#' with high posterior probability to be in the target toxicity interval.
#'
#' @details To avoid numerical problems, the dose selection algorithm has been
#' implemented as follows: First admissible doses are found, which are those
#' with probability to fall in `overdose` category being below `max_overdose_prob`.
#' Next, within the admissible doses, the maximum probability to fall in the
#' `target` category is calculated. If that is above 5% (i.e. it is not just
#' numerical error), then the corresponding dose is the next recommended dose.
#' Otherwise, the highest admissible dose is the next recommended dose.
#'
#' @slot target (`numeric`)\cr the target toxicity interval (limits included).
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included). It is used to filter probability samples.
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose posterior
#'   probability that is allowed, except 0 or 1.
#'
#' @aliases NextBestNCRM
#' @export
#'
.NextBestNCRM <- setClass(
  Class = "NextBestNCRM",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  ),
  contains = "NextBest",
  validity = v_next_best_ncrm
)

## constructor ----

#' @rdname NextBestNCRM-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestNCRM.R
#'
NextBestNCRM <- function(target,
                         overdose,
                         max_overdose_prob) {
  .NextBestNCRM(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob
  )
}

## default constructor ----

#' @rdname NextBestNCRM-class
#' @note Typically, end users will not use the `.DefaultNextBestNCRM()` function.
#' @export
.DefaultNextBestNCRM <- function() {
  NextBestNCRM(target = c(0.2, 0.35), overdose = c(0.35, 1), max_overdose_prob = 0.25)
}

# NextBestNCRMLoss ----

## class ----

#' `NextBestNCRMLoss`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestNCRMLoss`] is the class based on NCRM rule and loss function.
#' This class is similar to [`NextBestNCRM`] class, but differences are the
#' addition of loss function and re-defined toxicity intervals, see each
#' toxicity interval documentation and the note for details. As in NCRM rule, first admissible doses are found,
#' which are those with probability to fall in overdose category being below
#' `max_overdose_prob`. Next, within the admissible doses, the loss function is
#' calculated, i.e. `losses` %*% `target`. Finally, the corresponding
#' dose with lowest loss function (Bayes risk) is recommended for the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity interval (limits included).
#'   It has to be a probability range excluding 0 and 1.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included) or the excessive toxicity interval (lower
#'   limit excluded, upper limit included) if unacceptable is not provided.
#'   It has to be a probability range. It is used to filter probability samples.
#' @slot unacceptable (`numeric`)\cr an unacceptable toxicity
#'   interval (lower limit excluded, upper limit included). This must be
#'   specified if the `overdose` does not include 1. Otherwise, it is `c(1, 1)`
#'   (default), which is essentially a scalar equals 1. It has to be a
#'   probability range.
#' @slot losses (`numeric`)\cr a vector specifying the loss function. If the
#'   `unacceptable` is provided, the vector length must be 4, otherwise 3.
#'
#' @note The loss function should be a vector of either 3 or 4 values.
#'   This is because the loss function values must be specified for each
#'   interval, that is under-dosing, target toxicity, and overdosing toxicity or
#'   under-dosing, target toxicity, overdosing (excessive) toxicity, and
#'   unacceptable toxicity intervals.
#'
#' @aliases NextBestNCRMLoss
#' @export
#'
.NextBestNCRMLoss <- setClass(
  Class = "NextBestNCRMLoss",
  slots = c(
    unacceptable = "numeric",
    losses = "numeric"
  ),
  prototype = prototype(
    unacceptable = c(1, 1),
    losses = c(1, 0, 2)
  ),
  contains = "NextBestNCRM",
  validity = v_next_best_ncrm_loss
)

## constructor ----

#' @rdname NextBestNCRMLoss-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param unacceptable (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition in [`NextBestNCRM`].
#' @param losses (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestNCRMLoss.R
#'
NextBestNCRMLoss <- function(target,
                             overdose,
                             unacceptable = c(1, 1),
                             max_overdose_prob,
                             losses) {
  .NextBestNCRMLoss(
    target = target,
    overdose = overdose,
    unacceptable = unacceptable,
    max_overdose_prob = max_overdose_prob,
    losses = losses
  )
}

## default constructor ----

#' @rdname NextBestNCRMLoss-class
#' @note Typically, end users will not use the `.DefaultNextBestnCRMLoss()` function.
#' @export
.DefaultNextBestNCRMLoss <- function() {
  NextBestNCRMLoss(
    target = c(0.2, 0.35),
    overdose = c(0.35, 0.6),
    unacceptable = c(0.6, 1),
    max_overdose_prob = 0.25,
    losses = c(1, 0, 1, 2)
  )
}


# NextBestThreePlusThree ----

## class ----

#' `NextBestThreePlusThree`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestThreePlusThree`] is the class for next best dose that
#' implements the classical 3+3 dose recommendation. No input is required,
#' hence this class has no slots.
#'
#' @aliases NextBestThreePlusThree
#' @export
#'
.NextBestThreePlusThree <- setClass(
  Class = "NextBestThreePlusThree",
  contains = "NextBest"
)

## constructor ----

#' @rdname NextBestThreePlusThree-class
#'
#' @export
#' @examples
#' # Next best dose class object using the classical 3+3 design.
#' my_next_best <- NextBestThreePlusThree()
NextBestThreePlusThree <- function() {
  .NextBestThreePlusThree()
}

## default constructor ----

#' @rdname NextBestThreePlusThree-class
#' @note Typically, end users will not use the `.DefaultNextBestThreePlusThree()` function.
#' @export
.DefaultNextBestThreePlusThree <- function() {
  NextBestThreePlusThree()
}

# NextBestDualEndpoint ----

## class ----

#' `NextBestDualEndpoint`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestDualEndpoint`] is the class for next best dose that is based on the
#' dual endpoint model.
#'
#' @details Under this rule, at first admissible doses are found, which are those
#' with toxicity probability to fall in `overdose` category and being below
#' `max_overdose_prob`. Next, it picks (from the remaining admissible doses) the
#' one that maximizes the probability to be in the `target` biomarker range. By
#' default (`target_relative = TRUE`) the target is specified as relative to the
#' maximum biomarker level across the dose grid or relative to the `Emax`
#' parameter in case a parametric model was selected (i.e. [`DualEndpointBeta`],
#' [`DualEndpointEmax`]). However, if `target_relative = FALSE`, then the
#' absolute biomarker range can be used as a target.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, the target range \eqn{(0.8, 1.0)} and
#'   `target_relative = TRUE` means that we target a dose with at least
#'   \eqn{80\%} of maximum biomarker level. As an other example,
#'   \eqn{(0.5, 0.8)} would mean that we target a dose between \eqn{50\%} and
#'   \eqn{80\%} of the maximum biomarker level.
#' @slot overdose (`numeric`)\cr the overdose toxicity interval (lower limit
#'   excluded, upper limit included).
#' @slot max_overdose_prob (`proportion`)\cr maximum overdose probability that
#'   is allowed.
#' @slot target_relative (`flag`)\cr is `target` specified as relative? If
#'   `TRUE`, then the `target` is interpreted relative to the maximum, so it
#'   must be a probability range. Otherwise, the `target` is interpreted as
#'   absolute biomarker range.
#' @slot target_thresh (`proportion`)\cr a target probability threshold that
#'   needs to be fulfilled before the target probability will be used for
#'   deriving the next best dose (default to 0.01).
#'
#' @aliases NextBestDualEndpoint
#' @export
#'
.NextBestDualEndpoint <- setClass(
  Class = "NextBestDualEndpoint",
  slots = c(
    target = "numeric",
    overdose = "numeric",
    max_overdose_prob = "numeric",
    target_relative = "logical",
    target_thresh = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = TRUE,
    target_thresh = 0.01
  ),
  contains = "NextBest",
  validity = v_next_best_dual_endpoint
)

## constructor ----

#' @rdname NextBestDualEndpoint-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param overdose (`numeric`)\cr see slot definition.
#' @param max_overdose_prob (`proportion`)\cr see slot definition.
#' @param target_relative (`flag`)\cr see slot definition.
#' @param target_thresh (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestDualEndpoint.R
#'
NextBestDualEndpoint <- function(target,
                                 overdose,
                                 max_overdose_prob,
                                 target_relative = TRUE,
                                 target_thresh = 0.01) {
  .NextBestDualEndpoint(
    target = target,
    overdose = overdose,
    max_overdose_prob = max_overdose_prob,
    target_relative = target_relative,
    target_thresh = target_thresh
  )
}

## default constructor ----

#' @rdname NextBestDualEndpoint-class
#' @note Typically, end users will not use the `.DefaultNextBestDualEndpoint()` function.
#' @export
.DefaultNextBestDualEndpoint <- function() {
  NextBestDualEndpoint(
    target = c(200, 300),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25,
    target_relative = FALSE
  )
}

# NextBestMinDist ----

## class ----

#' `NextBestMinDist`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMinDist`] is the class for next best dose that is based on minimum
#' distance to target probability.
#'
#' @slot target (`proportion`)\cr single target toxicity probability, except
#'   0 or 1.
#'
#' @aliases NextBestMinDist
#' @export
#'
.NextBestMinDist <- setClass(
  Class = "NextBestMinDist",
  slots = c(
    target = "numeric"
  ),
  prototype = prototype(
    target = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_min_dist
)

## constructor ----

#' @rdname NextBestMinDist-class
#'
#' @param target (`proportion`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMinDist.R
#'
NextBestMinDist <- function(target) {
  .NextBestMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestMinDist()` function.
#' @export
.DefaultNextBestMinDist <- function() {
  NextBestMinDist(target = 0.3)
}

# NextBestInfTheory ----

## class ----

#' `NextBestInfTheory`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestInfTheory`] is the class for next best dose that is based on
#' information theory as proposed in https://doi.org/10.1002/sim.8450.
#'
#' @slot target (`proportion`)\cr target toxicity probability, except 0 or 1.
#' @slot asymmetry (`number`)\cr value of the asymmetry exponent in the
#'   divergence function that describes the rate of penalization for overly
#'   toxic does. It must be a value from \eqn{(0, 2)} interval.
#'
#' @aliases NextBestInfTheory
#' @export
#'
.NextBestInfTheory <- setClass(
  Class = "NextBestInfTheory",
  slots = c(
    target = "numeric",
    asymmetry = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    asymmetry = 1
  ),
  contains = "NextBest",
  validity = v_next_best_inf_theory
)

## constructor ----

#' @rdname NextBestInfTheory-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param asymmetry (`number`)\cr see slot definition.
#'
#' @export
#'
NextBestInfTheory <- function(target, asymmetry) {
  .NextBestInfTheory(target = target, asymmetry = asymmetry)
}

## default constructor ----

#' @rdname NextBestInfTheory-class
#' @note Typically, end users will not use the `.DefaultNextBestInfTheory()` function.
#' @export
.DefaultNextBestInfTheory <- function() {
  NextBestInfTheory(0.33, 1.2)
}

# NextBestTD ----

## class ----

#' `NextBestTD`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTD`] is the class to find a next best dose based on pseudo
#' DLT model without samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial without involving any samples, i.e. only DLT responses
#' will be incorporated for the dose-allocation. This is based solely on the
#' probabilities of the occurrence of a DLT obtained by using the modal estimates
#' of the model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model class.
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability (except 0 or 1)
#'   of the occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestTD
#' @export
#'
.NextBestTD <- setClass(
  Class = "NextBestTD",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## default constructor ----

#' @rdname NextBestTD-class
#' @note Typically, end users will not use the `.DefaultNextBestTD()` function.
#' @export
.DefaultNextBestTD <- function() {
  NextBestTD(0.35, 0.3)
}

## constructor ----

#' @rdname NextBestTD-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestTD(0.35, 0.3)
NextBestTD <- function(prob_target_drt, prob_target_eot) {
  .NextBestTD(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

# NextBestTDsamples ----

## class ----

#' `NextBestTDsamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestTDsamples`] is the class to find a next best dose based on Pseudo
#' DLT model with samples. Namely, it is to find two next best doses, one
#' for allocation during the trial and the second for final recommendation at
#' the end of a trial. Hence, there are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#'
#' @aliases NextBestTDsamples
#' @export
#'
.NextBestTDsamples <- setClass(
  Class = "NextBestTDsamples",
  slots = c(
    derive = "function"
  ),
  prototype = prototype(
    derive = function(dose_samples) {
      quantile(dose_samples, prob = 0.3)
    }
  ),
  contains = "NextBestTD",
  validity = v_next_best_td_samples
)

## constructor ----

#' @rdname NextBestTDsamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestTD`].
#' @param derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestTDsamples.R
#'
NextBestTDsamples <- function(prob_target_drt, prob_target_eot, derive) {
  .NextBestTDsamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive
  )
}

## default constructor ----

#' @rdname NextBestTDsamples-class
#' @note Typically, end users will not use the `.DefaultNextBestTDsamples()` function.
#' @export
.DefaultNextBestTDsamples <- function() {
  NextBestTDsamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, probs = 0.3))
    }
  )
}


# NextBestMaxGain ----

## class ----

#' `NextBestMaxGain`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGain`] is the class to find a next best dose with maximum gain
#' value based on a pseudo DLT and efficacy models without samples. It is based
#' solely on the probabilities of the occurrence of a DLT and the values
#' of the mean efficacy responses obtained by using the modal estimates of the
#' DLT and efficacy model parameters. There are two target probabilities of the
#' occurrence of a DLT that must be specified: target probability to be used
#' during the trial and target probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes (except [`EffFlexi`]).
#'
#' @slot prob_target_drt (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used during the trial.
#' @slot prob_target_eot (`proportion`)\cr the target probability of the
#'   occurrence of a DLT to be used at the end of the trial.
#'
#' @aliases NextBestMaxGain
#' @export
#'
.NextBestMaxGain <- setClass(
  Class = "NextBestMaxGain",
  slots = c(
    prob_target_drt = "numeric",
    prob_target_eot = "numeric"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3
  ),
  contains = "NextBest",
  validity = v_next_best_td
)

## constructor ----

#' @rdname NextBestMaxGain-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition.
#' @param prob_target_eot (`proportion`)\cr see slot definition.
#'
#' @export
#' @examples
#' my_next_best <- NextBestMaxGain(0.35, 0.3)
NextBestMaxGain <- function(prob_target_drt, prob_target_eot) {
  .NextBestMaxGain(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot
  )
}

## default constructor ----

#' @rdname NextBestMaxGain-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGain()` function.
#' @export
.DefaultNextBestMaxGain <- function() {
  NextBestMaxGain(0.35, 0.3)
}

# NextBestMaxGainSamples ----

## class ----

#' `NextBestMaxGainSamples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`NextBestMaxGainSamples`] is the class to find a next best dose with maximum
#' gain value based on a pseudo DLT and efficacy models and DLT and efficacy
#' samples. There are two target probabilities of the occurrence of a DLT that
#' must be specified: target probability to be used during the trial and target
#' probability to be used at the end of the trial.
#' It is suitable to use it only with the [`ModelTox`] model and [`ModelEff`]
#' classes.
#'
#' @slot derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples, the target dose that has the probability of the occurrence of
#'   DLT equals to either the `prob_target_drt` or `prob_target_eot`. It must
#'   therefore accept one and only one argument, which is a numeric vector, and
#'   return a number.
#' @slot mg_derive (`function`)\cr derives, based on a vector of posterior dose
#'   samples that give the maximum gain value, the final next best estimate of
#'   the dose that gives the maximum gain value. It must therefore accept one
#'   and only one argument, which is a numeric vector, and return a number.
#'
#' @aliases NextBestMaxGainSamples
#' @export
#'
.NextBestMaxGainSamples <- setClass(
  Class = "NextBestMaxGainSamples",
  slots = c(
    derive = "function",
    mg_derive = "function"
  ),
  prototype = prototype(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.3))
    },
    mg_derive = function(dose_samples) {
      as.numeric(quantile(dose_samples, prob = 0.5))
    }
  ),
  contains = "NextBestMaxGain",
  validity = v_next_best_max_gain_samples
)

## constructor ----

#' @rdname NextBestMaxGainSamples-class
#'
#' @param prob_target_drt (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param prob_target_eot (`proportion`)\cr see slot definition in [`NextBestMaxGain`].
#' @param derive (`function`)\cr see slot definition.
#' @param mg_derive (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-NextBestMaxGainSamples.R
#'
NextBestMaxGainSamples <- function(prob_target_drt,
                                   prob_target_eot,
                                   derive,
                                   mg_derive) {
  .NextBestMaxGainSamples(
    prob_target_drt = prob_target_drt,
    prob_target_eot = prob_target_eot,
    derive = derive,
    mg_derive = mg_derive
  )
}

## default constructor ----

#' @rdname NextBestMaxGainSamples-class
#' @note Typically, end users will not use the `.DefaultNextBestMaxGainSamples()` function.
#' @export
.DefaultNextBestMaxGainSamples <- function() {
  NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )
}

# NextBestProbMTDLTE ----

## class ----

#' `NextBestProbMTDLTE`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDLTE`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate less or equal
#' to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the maximum dose that has a toxicity
#' probability below or equal to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered in the calculation and removed from the dose grid for
#' any calculations.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDLTE
#' @export
#'
.NextBestProbMTDLTE <- setClass(
  Class = "NextBestProbMTDLTE",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_lte
)

## constructor ----

#' @rdname NextBestProbMTDLTE-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDLTE.R
#'
NextBestProbMTDLTE <- function(target) {
  .NextBestProbMTDLTE(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDLTE-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDLTE()` function.
#' @export
.DefaultNextBestProbMTDLTE <- function() {
  NextBestProbMTDLTE(target = 0.3)
}

# NextBestProbMTDMinDist ----

## class ----

#' `NextBestProbMTDMinDist`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestProbMTDMinDist`] is the class of finding a next best dose that selects
#' the dose with the highest probability of having a toxicity rate with the
#' smallest distance to the toxicity target.
#' The dose is determined by calculating the posterior toxicity probability
#' for each dose per iteration and select the dose that has the smallest toxicity
#' probability distance to the target. The dose with the highest frequency
#' of being selected as MTD across iterations is the next best dose. Placebo
#' is not considered as the next dose and for that reason not used in
#' calculations. I.e. for placebo the toxicity probability distance to target
#' is not calculated and taken into account for determination of the next dose.
#'
#' @slot target (`numeric`)\cr the target toxicity probability.
#'
#' @aliases NextBestProbMTDMinDist
#' @export
#'
.NextBestProbMTDMinDist <- setClass(
  Class = "NextBestProbMTDMinDist",
  slots = c(target = "numeric"),
  prototype = prototype(target = 0.3),
  contains = "NextBest",
  validity = v_next_best_prob_mtd_min_dist
)

## constructor ----

#' @rdname NextBestProbMTDMinDist-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestProbMTDMinDist.R
#'
NextBestProbMTDMinDist <- function(target) {
  .NextBestProbMTDMinDist(target = target)
}

## default constructor ----

#' @rdname NextBestProbMTDMinDist-class
#' @note Typically, end users will not use the `.DefaultNextBestProbMTDMinDist()` function.
#' @export
.DefaultNextBestProbMTDMinDist <- function() {
  NextBestProbMTDMinDist(target = 0.3)
}

# NextBestOrdinal ----

## class ----

#' `NextBestOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`NextBestOrdinal`] is the class for applying a standard `NextBest` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`NextBest`)\cr the standard `NextBest` rule to be applied
#'
#' @aliases NextBestOrdinal
#' @export
#'
.NextBestOrdinal <- setClass(
  Class = "NextBestOrdinal",
  slots = c(grade = "numeric", rule = "NextBest"),
  contains = "NextBest",
  validity = v_next_best_ordinal
)

## constructor ----

#' @rdname NextBestOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`NextBest`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-NextBestOrdinal.R
#'
NextBestOrdinal <- function(grade, rule) {
  .NextBestOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname NextBestOrdinal-class
#' @note Typically, end users will not use the `.DefaultNextBestOrdinal()` function.
#' @export
.DefaultNextBestOrdinal <- function() {
  NextBestOrdinal(
    grade = 1L,
    rule = NextBestMTD(
      0.25,
      function(mtd_samples) {
        quantile(mtd_samples, probs = 0.25)
      }
    )
  )
}

# Increments ----

## class ----

#' `Increments`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Increments`] is a virtual class for controlling increments, from which all
#' other specific increments classes inherit.
#'
#' @seealso [`IncrementsRelative`], [`IncrementsRelativeDLT`],
#'   [`IncrementsDoseLevels`], [`IncrementsHSRBeta`], [`IncrementsMin`].
#'
#' @aliases Increments
#' @export
#'
setClass(
  Class = "Increments",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname Increments-class
#' @note Typically, end users will not use the `.DefaultIncrements()` function.
#' @export
.DefaultIncrements <- function() {
  stop(paste0("Class Increments cannot be instantiated directly.  Please use one of its subclasses instead."))
}


# IncrementsRelative ----

## class ----

#' `IncrementsRelative`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelative`] is the class for increments control based on relative
#' differences in intervals.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   intervals. For example, `intervals  = c(0, 50, 100)` specifies three intervals:
#'   \eqn{(0, 50)}, \eqn{[50, 100)} and \eqn{[100, +Inf)}. That means, the right
#'   bound of the intervals are exclusive to the interval and the last interval
#'   goes from the last value to infinity.
#' @slot increments (`numeric`)\cr a vector of the same length with the maximum
#'   allowable relative increments in the `intervals`.
#'
#' @aliases IncrementsRelative
#' @export
#'
.IncrementsRelative <- setClass(
  Class = "IncrementsRelative",
  slots = c(
    intervals = "numeric",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0, 2),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative
)

## constructor ----

#' @rdname IncrementsRelative-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative.R
#'
IncrementsRelative <- function(intervals, increments) {
  .IncrementsRelative(
    intervals = intervals,
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelative-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelative()` function.
#' @export
.DefaultIncrementsRelative <- function() {
  IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
}


# IncrementsRelativeDLT ----

## class ----

#' `IncrementsRelativeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeDLT`] is the class for increments control based on
#' relative differences in terms of DLTs.
#'
#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals. For example, `intervals  = c(0, 1, 3)` specifies
#'   three intervals (sets of DLTs: first, 0 DLT; second 1 or 2 DLTs; and the third
#'   one, at least 3 DLTs. That means, the right bound of the intervals are
#'   exclusive to the interval and the last interval goes from the last value to
#'   infinity.
#' @slot increments (`numeric`)\cr a vector of maximum allowable relative
#'   increments corresponding to `intervals`. IT must be of the same length
#'   as the length of `intervals`.
#'
#' @note This considers all DLTs across all cohorts observed so far.
#'
#' @seealso [IncrementsRelativeDLTCurrent] which only considers the DLTs
#'   in the current cohort.
#'
#' @aliases IncrementsRelativeDLT
#' @export
#'
.IncrementsRelativeDLT <- setClass(
  Class = "IncrementsRelativeDLT",
  slots = representation(
    intervals = "integer",
    increments = "numeric"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    increments = c(2, 1)
  ),
  contains = "Increments",
  validity = v_increments_relative_dlt
)

## constructor ----

#' @rdname IncrementsRelativeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param increments (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLT.R
#'
IncrementsRelativeDLT <- function(intervals, increments) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLT(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLT-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLT()` function.
#' @export
.DefaultIncrementsRelativeDLT <- function() {
  IncrementsRelativeDLT(intervals = c(0L, 1L, 3L), increments = c(1, 0.33, 0.2))
}

# IncrementsRelativeDLTCurrent ----

## class ----

#' `IncrementsRelativeDLTCurrent`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsRelativeDLTCurrent`] is the class for increments control based on
#' relative differences and current DLTs. The class is based on the number of
#' DLTs observed in the current cohort, but not cumulatively over all cohorts
#' so far.
#'
#' @seealso [IncrementsRelativeDLT].
#'
#' @aliases IncrementsRelativeDLTCurrent
#' @export
#'
.IncrementsRelativeDLTCurrent <- setClass(
  Class = "IncrementsRelativeDLTCurrent",
  contains = "IncrementsRelativeDLT"
)

## constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#'
#' @inheritParams IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-class-IncrementsRelativeDLTCurrent.R
#'
IncrementsRelativeDLTCurrent <- function(intervals = c(0L, 1L),
                                         increments = c(2L, 1L)) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  assert_numeric(increments, any.missing = FALSE, lower = 0)

  .IncrementsRelativeDLTCurrent(
    intervals = as.integer(intervals),
    increments = increments
  )
}

## default constructor ----

#' @rdname IncrementsRelativeDLTCurrent-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeDLTCurrent()` function.
#' @export
.DefaultIncrementsRelativeDLTCurrent <- function() { # nolint
  IncrementsRelativeDLTCurrent(intervals = c(0L, 1L, 3L), increments = c(1, 0.33, 0.2))
}

# IncrementsRelativeParts ----

## class ----

#' `IncrementsRelativeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsRelativeParts`] is the class for increments control based on
#' relative differences in intervals, with special rules for part 1 and
#' beginning of part 2.
#'
#' @details This class works only in conjunction with [`DataParts`] objects. If
#' part 2 will just be started in the next cohort, then the next maximum dose
#' will be either `dlt_start` (e.g. -1) shift of the last part 1 dose in case
#' of a DLT in part 1, or `clean_start` shift (e.g. -1) in case of no DLTs in
#' part 1, given that `clean_start <= 0` (see description of `clean_start`
#' slot for more details). If part 1 will still be on in the next cohort,
#' then the next dose level will be the next higher dose level in the
#' `part1Ladder` slot of the data object. If part 2 has been started before,
#' the usual relative increment rules apply, see [`IncrementsRelative`].
#'
#' @slot dlt_start (`integer`)\cr a scalar, the dose level increment for starting
#'   part 2 in case of at least one DLT event in part 1.
#' @slot clean_start (`integer`)\cr a scalar, the dose level increment for
#'   starting part 2 in case of no DLTs in part 1. If `clean_start <= 0`,
#'   then the part 1 ladder will be used to find the maximum next dose.
#'   Otherwise, the relative increment rules will be applied to find the next
#'   maximum dose level.
#'
#' @note We require that `clean_start >= dlt_start`. However, this precondition
#'   is not a prerequisite for any function (except of the class' validation
#'   function) that works with objects of this class. It is rather motivated by
#'   the semantics. That is, if we observe a DLT in part 1, we cannot be more
#'   aggressive than in case of a clean part 1 without DLT.
#'
#' @aliases IncrementsRelativeParts
#' @export
#'
.IncrementsRelativeParts <- setClass(
  Class = "IncrementsRelativeParts",
  slots = representation(
    dlt_start = "integer",
    clean_start = "integer"
  ),
  prototype = prototype(
    dlt_start = -1L,
    clean_start = 1L
  ),
  contains = "IncrementsRelative",
  validity = v_increments_relative_parts
)

## constructor ----

#' @rdname IncrementsRelativeParts-class
#'
#' @param dlt_start (`count`)\cr see slot definition.
#' @param clean_start (`count`)\cr see slot definition.
#' @inheritDotParams IncrementsRelative
#'
#' @export
#' @example examples/Rules-class-IncrementsRelative-DataParts.R
#'
IncrementsRelativeParts <- function(dlt_start, clean_start, ...) {
  assert_integerish(dlt_start)
  assert_integerish(clean_start)

  .IncrementsRelativeParts(
    dlt_start = as.integer(dlt_start),
    clean_start = as.integer(clean_start),
    ...
  )
}

## default constructor ----

#' @rdname IncrementsRelativeParts-class
#' @note Typically, end users will not use the `.DefaultIncrementsRelativeParts()` function.
#' @export
.DefaultIncrementsRelativeParts <- function() {
  IncrementsRelativeParts(dlt_start = 0L, clean_start = 1L)
}

# IncrementsDoseLevels ----

## class ----

#' `IncrementsDoseLevels`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsDoseLevels`] is the class for increments control based on the
#' number of dose levels.
#'
#' @slot levels (`count`)\cr maximum number of dose levels to increment for
#'   the next dose. It defaults to 1, which means that no dose skipping is
#'   allowed, i.e. the next dose can be maximum one level higher than the current
#'   base dose. The current base dose level is the dose level used to increment
#'   from (see `basis_level` parameter).
#' @slot basis_level (`string`)\cr defines the current base dose level. It can
#'   take one out of two possible values: `last` or `max`.
#'   If `last` is specified (default), the current base dose level is set to the
#'   last dose given. If `max` is specified, then the current base dose level is
#'   set to the maximum dose level given.
#'
#' @aliases IncrementsDoseLevels
#' @export
#'
.IncrementsDoseLevels <- setClass(
  Class = "IncrementsDoseLevels",
  slots = representation(
    levels = "integer",
    basis_level = "character"
  ),
  prototype = prototype(
    levels = 1L,
    basis_level = "last"
  ),
  contains = "Increments",
  validity = v_increments_dose_levels
)

## constructor ----

#' @rdname IncrementsDoseLevels-class
#'
#' @param levels (`count`)\cr see slot definition.
#' @param basis_level (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-IncrementsDoseLevels.R
#'
IncrementsDoseLevels <- function(levels = 1L, basis_level = "last") {
  assert_count(levels, positive = TRUE)
  assert_string(basis_level)
  assert_subset(basis_level, c("last", "max"))

  .IncrementsDoseLevels(
    levels = as.integer(levels),
    basis_level = basis_level
  )
}

## default constructor ----

#' @rdname IncrementsDoseLevels-class
#' @note Typically, end users will not use the `.DefaultIncrementsDoseLevels()` function.
#' @export
.DefaultIncrementsDoseLevels <- function() {
  IncrementsDoseLevels(levels = 2L, basis_level = "last")
}

# IncrementsHSRBeta ----

## class ----

#' `IncrementsHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsHSRBeta`] is a class for limiting further increments using
#' a Hard Safety Rule based on the Bin-Beta model.
#' Increment control is based on the number of observed DLTs and number of
#' subjects at each dose level. The probability of toxicity is calculated
#' using a Bin-Beta model with prior (a,b). If the probability exceeds
#' the threshold for a given dose, that dose and all doses above are excluded
#' from further escalation.
#' This is a hard safety rule that limits further escalation based on the
#' observed data per dose level, independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity, except
#'   0 or 1.
#' @slot prob (`proportion`)\cr the threshold probability (except 0 or 1) for
#'   a dose being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases IncrementsHSRBeta
#' @export
#'
.IncrementsHSRBeta <- setClass(
  Class = "IncrementsHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Increments",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname IncrementsHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsHSRBeta.R
#' @export
#'
IncrementsHSRBeta <- function(target = 0.3,
                              prob = 0.95,
                              a = 1,
                              b = 1) {
  .IncrementsHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b
  )
}

## default constructor ----

#' @rdname IncrementsHSRBeta-class
#' @note Typically, end users will not use the `.DefaultIncrementsHSRBeta()` function.
#' @export
.DefaultIncrementsHSRBeta <- function() {
  IncrementsHSRBeta(target = 0.3, prob = 0.95)
}

# IncrementsMin ----

## class ----

#' `IncrementsMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`IncrementsMin`] is the class that combines multiple increment rules with
#' the `minimum` operation. Slot `increments_list` contains all increment rules,
#' which are itself the objects of class [`Increments`]. The minimum of these
#' individual increments is taken to give the final maximum increment.
#'
#' @slot increments_list (`list`)\cr list with increment rules.
#'
#' @aliases IncrementsMin
#' @export
#'
.IncrementsMin <- setClass(
  Class = "IncrementsMin",
  slots = c(increments_list = "list"),
  prototype = prototype(
    increments_list = list(
      IncrementsRelativeDLT(intervals = c(0L, 1L), increments = c(2, 1)),
      IncrementsRelative(intervals = c(0, 2), increments = c(2, 1))
    )
  ),
  contains = "Increments",
  validity = v_increments_min
)

## constructor ----

#' @rdname IncrementsMin-class
#'
#' @param increments_list (`list`)\cr see slot definition.
#'
#' @example examples/Rules-class-IncrementsMin.R
#' @export
#'
IncrementsMin <- function(increments_list) {
  .IncrementsMin(increments_list = increments_list)
}
## default constructor ----

#' @rdname IncrementsMin-class
#' @note Typically, end users will not use the `.DefaultIncrementsMin()` function.
#' @export
.DefaultIncrementsMin <- function() {
  IncrementsMin(
    increments_list = list(
      IncrementsRelativeDLT(intervals = c(0, 1, 3), increments = c(1, 0.33, 0.2)),
      IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
    )
  )
}

# IncrementsOrdinal ----

## class ----

#' `IncrementsOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`IncrementsOrdinal`] is the class for applying a standard `Increments` rule to
#' the results of an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the toxicity grade to which the `rule` should be
#' applied.
#' @slot rule (`Increments`)\cr the standard `Increments` rule to be applied
#'
#' @aliases IncrementsOrdinal
#' @export
#'
.IncrementsOrdinal <- setClass(
  Class = "IncrementsOrdinal",
  slots = c(grade = "numeric", rule = "Increments"),
  contains = "Increments",
  validity = v_increments_ordinal
)

## constructor ----

#' @rdname IncrementsOrdinal-class
#'
#' @param grade (`numeric`)\cr see slot definition.
#' @param rule (`Increments`)\cr see slot definition.
#' @export
#' @example examples/Rules-class-IncrementsOrdinal.R
#'
IncrementsOrdinal <- function(grade, rule) {
  .IncrementsOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname IncrementsOrdinal-class
#' @note Typically, end users will not use the `.DefaultIncrementsOrdinal()` function.
#' @export
.DefaultIncrementsOrdinal <- function() {
  IncrementsOrdinal(
    grade = 1L,
    rule = IncrementsRelative(intervals = c(0, 20), increments = c(1, 0.33))
  )
}

# Stopping ----

## class ----

#' `Stopping`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Stopping`] is a class for stopping rules.
#'
#' @slot report_label (`string`)\cr a label for the stopping report. The meaning
#'   of this parameter is twofold. If it is equal to `NA_character_` (default),
#'   the `report_label` will not be used in the report at all. Otherwise, if it
#'   is specified as an empty character (i.e. `character(0)`) in a user constructor,
#'   then a default, class-specific label will be created for this slot.
#'   Finally, for the remaining cases, a user can provide a custom label.
#'
#' @seealso [`StoppingList`], [`StoppingCohortsNearDose`], [`StoppingPatientsNearDose`],
#'   [`StoppingMinCohorts`], [`StoppingMinPatients`], [`StoppingTargetProb`],
#'   [`StoppingMTDdistribution`], [`StoppingTargetBiomarker`], [`StoppingHighestDose`]
#'   [`StoppingMTDCV`], [`StoppingLowestDoseHSRBeta`], [`StoppingSpecificDose`].
#'
#' @aliases Stopping
#' @export
#'
setClass(
  Class = "Stopping",
  contains = "CrmPackClass",
  slots = c(report_label = "character"),
  prototype = prototype(report_label = character(0))
)


## default constructor ----

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0("Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."))
}

# StoppingMissingDose ----

## class ----

#' `StoppingMissingDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMissingDose`] is the class for stopping based on NA returned by
#'  next best dose.
#'
#' @aliases StoppingMissingDose
#' @export
#'
.StoppingMissingDose <- setClass(
  Class = "StoppingMissingDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingMissingDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#' @example examples/Rules-class-StoppingMissingDose.R
#' @export
#'
StoppingMissingDose <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("Stopped because of missing dose")
  )

  .StoppingMissingDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingMissingDose-class
#' @note Typically, end users will not use the `.DefaultStoppingMissingDose()` function.
#' @export
#'
.DefaultStoppingMissingDose <- function() {
  StoppingMissingDose()
}

# StoppingCohortsNearDose ----

## class ----

#' `StoppingCohortsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingCohortsNearDose`] is the class for stopping based on number of
#' cohorts near to next best dose.
#'
#'
#' @slot nCohorts (`number`)\cr number of required cohorts.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the cohorts must lie.
#'
#' @aliases StoppingCohortsNearDose
#' @export
#'
.StoppingCohortsNearDose <- setClass(
  Class = "StoppingCohortsNearDose",
  slots = c(
    nCohorts = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nCohorts = 2L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_cohorts_near_dose
)

## constructor ----

#' @rdname StoppingCohortsNearDose-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingCohortsNearDose.R
#' @export
#'
StoppingCohortsNearDose <- function(nCohorts = 2L,
                                    percentage = 50,
                                    report_label = NA_character_) {
  assert_count(nCohorts, positive = TRUE)
  assert_numeric(percentage, lower = 0)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nCohorts, "cohorts dosed in", percentage, "% dose range around NBD")
  )

  .StoppingCohortsNearDose(
    nCohorts = as.integer(nCohorts),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingCohortsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingCohortsNearDose()` function.
#' @export
.DefaultStoppingCohortsNearDose <- function() { # nolint
  StoppingCohortsNearDose(
    nCohorts = 3L,
    percentage = 0.2
  )
}


# StoppingPatientsNearDose ----

## class ----

#' `StoppingPatientsNearDose`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingPatientsNearDose`] is the class for stopping based on number of
#' patients near to next best dose.
#'
#' @slot nPatients (`number`)\cr number of required patients.
#' @slot percentage (`number`)\cr percentage (between and including 0 and 100)
#'   within the next best dose the patients must lie.
#'
#' @aliases StoppingPatientsNearDose
#' @export
#'
.StoppingPatientsNearDose <- setClass(
  Class = "StoppingPatientsNearDose",
  slots = c(
    nPatients = "integer",
    percentage = "numeric"
  ),
  prototype = prototype(
    nPatients = 10L,
    percentage = 50
  ),
  contains = "Stopping",
  validity = v_stopping_patients_near_dose
)

## constructor ----

#' @rdname StoppingPatientsNearDose-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param percentage (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingPatientsNearDose.R
#' @export
#'
StoppingPatientsNearDose <- function(nPatients = 10L,
                                     percentage = 50,
                                     report_label = NA_character_) {
  assert_count(nPatients, positive = TRUE)
  assert_number(percentage, lower = 0, upper = 100)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nPatients, "patients dosed in", percentage, "% dose range around NBD")
  )

  .StoppingPatientsNearDose(
    nPatients = as.integer(nPatients),
    percentage = percentage,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingPatientsNearDose-class
#' @note Typically, end users will not use the `.DefaultStoppingPatientsNearDose()` function.
#' @export
.DefaultStoppingPatientsNearDose <- function() { # nolint
  StoppingPatientsNearDose(
    nPatients = 9L,
    percentage = 20,
    report_label = NA_character_
  )
}

# StoppingMinCohorts ----

## class ----

#' `StoppingMinCohorts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinCohorts`] is the class for stopping based on minimum number of
#' cohorts.
#'
#' @slot nCohorts (`number`)\cr minimum required number of cohorts.
#'
#' @aliases StoppingMinCohorts
#' @export
#'
.StoppingMinCohorts <- setClass(
  Class = "StoppingMinCohorts",
  slots = c(nCohorts = "integer"),
  prototype = prototype(nCohorts = 2L),
  contains = "Stopping",
  validity = v_stopping_min_cohorts
)

## constructor ----

#' @rdname StoppingMinCohorts-class
#'
#' @param nCohorts (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinCohorts.R
#' @export
#'
StoppingMinCohorts <- function(nCohorts = 2L,
                               report_label = NA_character_) {
  assert_count(nCohorts, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nCohorts, "cohorts dosed")
  )

  .StoppingMinCohorts(
    nCohorts = as.integer(nCohorts),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinCohorts-class
#' @note Typically, end users will not use the `.DefaultStoppingMinCohorts()` function.
#' @export
.DefaultStoppingMinCohorts <- function() {
  StoppingMinCohorts(
    nCohorts = 6L
  )
}

# StoppingMinPatients ----

## class ----

#' `StoppingMinPatients`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMinPatients`] is the class for stopping based on minimum number of
#' patients
#'
#' @slot nPatients (`number`)\cr minimum allowed number of patients.
#'
#' @aliases StoppingMinPatients
#' @export
#'
.StoppingMinPatients <- setClass(
  Class = "StoppingMinPatients",
  slots = c(nPatients = "integer"),
  prototype = prototype(nPatients = 20L),
  contains = "Stopping",
  validity = v_stopping_min_patients
)

## constructor ----

#' @rdname StoppingMinPatients-class
#'
#' @param nPatients (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMinPatients.R
#' @export
#'
StoppingMinPatients <- function(nPatients = 20L,
                                report_label = NA_character_) {
  assert_count(nPatients, positive = TRUE)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("\u2265", nPatients, "patients dosed")
  )

  .StoppingMinPatients(
    nPatients = as.integer(nPatients),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMinPatients-class
#' @note Typically, end users will not use the `.DefaultStoppingMinPatients()` function.
#' @export
.DefaultStoppingMinPatients <- function() {
  StoppingMinPatients(
    nPatients = 20L
  )
}

# StoppingTargetProb ----

## class ----

#' `StoppingTargetProb`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetProb`] is the class for stopping based on the probability of
#' the DLT rate being in the target toxicity interval.
#'
#' @slot target (`number`)\cr the target toxicity interval, e.g. `c(0.2, 0.35)`.
#' @slot prob (`proportion`)\cr required target toxicity probability (except 0 or 1)
#'   for reaching sufficient precision.
#'
#' @aliases StoppingTargetProb
#' @export
#'
.StoppingTargetProb <- setClass(
  Class = "StoppingTargetProb",
  slots = c(
    target = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.2, 0.35),
    prob = 0.4
  ),
  contains = "Stopping",
  validity = v_stopping_target_prob
)

## constructor ----

#' @rdname StoppingTargetProb-class
#'
#' @param target (`number`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingTargetProb.R
#' @export
#'
StoppingTargetProb <- function(target = c(0.2, 0.35),
                               prob = 0.4,
                               report_label = NA_character_) {
  assert_numeric(target, len = 2)
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P(", target[1], " \u2264 prob(DLE | NBD) \u2264 ", target[2], ") \u2265 ", prob)
  )

  .StoppingTargetProb(
    target = target,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetProb-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetProb()` function.
#' @export
.DefaultStoppingTargetProb <- function() {
  StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
}

# StoppingMTDdistribution ----

## class ----

#' `StoppingMTDdistribution`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMTDdistribution`] is the class for stopping based on the posterior
#' distribution of the MTD. It is used for the cases where the stopping occurs
#' when the probability of `MTD > thresh * next_dose` is greater than or equal
#' to `prob`, where the `next_dose` is the recommended next best dose.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr the target toxicity probability (except 0 or 1)
#'   defining the MTD.
#' @slot thresh (`proportion`)\cr the threshold (except 0 or 1) relative to the
#'   recommended next best dose.
#' @slot prob (`proportion`)\cr required minimum probability, except 0 or 1.
#'
#' @aliases StoppingMTDdistribution
#' @export
#'
.StoppingMTDdistribution <- setClass(
  Class = "StoppingMTDdistribution",
  slots = c(
    target = "numeric",
    thresh = "numeric",
    prob = "numeric"
  ),
  prototype = prototype(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_distribution
)

## constructor ----

#' @rdname StoppingMTDdistribution-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @example examples/Rules-class-StoppingMTDdistribution.R
#' @export
#'
StoppingMTDdistribution <- function(target = 0.33,
                                    thresh = 0.5,
                                    prob = 0.9,
                                    report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P(MTD > ", thresh, " * NBD | P(DLE) = ", target, ") \u2265 ", prob)
  )

  .StoppingMTDdistribution(
    target = target,
    thresh = thresh,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDdistribution-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDDistribution()` function.
#' @export
.DefaultStoppingMTDdistribution <- function() {
  StoppingMTDdistribution(
    target = 0.33,
    thresh = 0.5,
    prob = 0.9
  )
}

# StoppingMTDCV ----

## class ----

#' `StoppingMTDCV`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingMTDCV`] is a class for stopping rule based on precision of MTD
#' which is calculated as the coefficient of variation (CV) of the MTD.
#' Here, the MTD is defined as the dose that reaches a specific `target`
#' probability of the occurrence of a DLT.
#'
#' @slot target (`proportion`)\cr toxicity target of MTD (except 0 or 1).
#' @slot thresh_cv (`number`)\cr threshold (percentage > 0) for CV to be
#'   considered accurate enough to stop the trial. The stopping occurs when the
#'   CV is less than or equal to `tresh_cv`.
#'
#' @aliases StoppingMTDCV
#' @export
#'
.StoppingMTDCV <- setClass(
  Class = "StoppingMTDCV",
  slots = c(
    target = "numeric",
    thresh_cv = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    thresh_cv = 40
  ),
  contains = "Stopping",
  validity = v_stopping_mtd_cv
)

## constructor ----

#' @rdname StoppingMTDCV-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param thresh_cv (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMTDCV.R
#'
StoppingMTDCV <- function(target = 0.3,
                          thresh_cv = 40,
                          report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("CV(MTD) >", target)
  )

  .StoppingMTDCV(
    target = target,
    thresh_cv = thresh_cv,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingMTDCV-class
#' @note Typically, end users will not use the `.DefaultStoppingMTDCV()` function.
#'
#' @export
.DefaultStoppingMTDCV <- function() {
  StoppingMTDCV(
    target = 0.3,
    thresh_cv = 40
  )
}

# StoppingLowestDoseHSRBeta ----

## class ----

#' `StoppingLowestDoseHSRBeta`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingLowestDoseHSRBeta`] is a class for stopping based on a Hard Safety
#' Rule using the Beta posterior distribution with Beta(a,b) prior and a
#' Bin-Beta model based on the observed data at the lowest dose level.
#' The rule is triggered when the first dose is considered to be toxic
#' (i.e. above threshold probability) based on the observed data at the
#' lowest dose level and a Beta(a,b) prior distribution.
#' The default prior is Beta(1,1).
#' In case that placebo is used, the rule is evaluated at the second dose of the
#' dose grid, i.e. at the lowest non-placebo dose.
#'
#' @note This stopping rule is independent from the underlying model.
#'
#' @slot target (`proportion`)\cr the target toxicity.
#' @slot prob (`proportion`)\cr the threshold probability for the lowest dose
#'   being toxic.
#' @slot a (`number`)\cr shape parameter \eqn{a > 0} of probability distribution
#'   Beta (a,b).
#' @slot b (`number`)\cr shape parameter \eqn{b > 0} of probability distribution
#'   Beta (a,b).
#'
#' @aliases StoppingLowestDoseHSRBeta
#' @export
#'
.StoppingLowestDoseHSRBeta <- setClass(
  Class = "StoppingLowestDoseHSRBeta",
  slots = c(
    target = "numeric",
    prob = "numeric",
    a = "numeric",
    b = "numeric"
  ),
  prototype = prototype(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  ),
  contains = "Stopping",
  validity = v_increments_hsr_beta
)

## constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#'
#' @param target (`proportion`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param a (`number`)\cr see slot definition.
#' @param b (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingLowestDoseHSRBeta.R
#'
StoppingLowestDoseHSRBeta <- function(target = 0.3,
                                      prob = 0.95,
                                      a = 1,
                                      b = 1,
                                      report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("P\u03B2(lowest dose > P(DLE) = ", target, ") > ", prob)
  )

  .StoppingLowestDoseHSRBeta(
    target = target,
    prob = prob,
    a = a,
    b = b,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingLowestDoseHSRBeta-class
#' @note Typically, end users will not use the `.DefaultStoppingLowestDoseHSRBeta()` function.
#' @export
.DefaultStoppingLowestDoseHSRBeta <- function() { # nolint
  StoppingLowestDoseHSRBeta(
    target = 0.3,
    prob = 0.95,
    a = 1,
    b = 1
  )
}

# StoppingTargetBiomarker ----

## class ----

#' `StoppingTargetBiomarker`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTargetBiomarker`] is a class for stopping based on probability of
#' target biomarker.
#'
#' @slot target (`numeric`)\cr the biomarker target range that needs to be
#'   reached. For example, `target = c(0.8, 1.0)` with `is_relative = TRUE`
#'   means that we target a dose with at least 80% of maximum biomarker level.
#' @slot is_relative (`flag`)\cr is target relative? If it so (default), then
#'   the `target` is interpreted relative to the maximum, so it must be a
#'   probability range. Otherwise, the `target` is interpreted as absolute
#'   biomarker range.
#' @slot prob (`proportion`)\cr required target probability (except 0 or 1) for
#'   reaching sufficient precision.
#'
#' @aliases StoppingTargetBiomarker
#' @export
#'
.StoppingTargetBiomarker <- setClass(
  Class = "StoppingTargetBiomarker",
  slots = c(
    target = "numeric",
    is_relative = "logical",
    prob = "numeric"
  ),
  prototype = prototype(
    target = c(0.9, 1),
    is_relative = TRUE,
    prob = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_target_biomarker
)

## constructor ----

#' @rdname StoppingTargetBiomarker-class
#'
#' @param target (`numeric`)\cr see slot definition.
#' @param prob (`proportion`)\cr see slot definition.
#' @param is_relative (`flag`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTargetBiomarker.R
#'
StoppingTargetBiomarker <- function(target = c(0.9, 1),
                                    prob = 0.3,
                                    is_relative = TRUE,
                                    report_label = NA_character_) {
  assert_numeric(target, len = 2)
  assert_flag(is_relative)

  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0(
      "P(", target[1], " \u2264 ", "Biomarker \u2264 ", target[2], ") \u2265 ", prob,
      ifelse(is_relative, " (relative)", " (absolute)")
    )
  )

  .StoppingTargetBiomarker(
    target = target,
    is_relative = is_relative,
    prob = prob,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTargetBiomarker-class
#' @note Typically, end users will not use the `.DefaultStoppingTargetBiomarker()` function.
#' @export
.DefaultStoppingTargetBiomarker <- function() {
  StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5,
    is_relative = TRUE
  )
}

# StoppingSpecificDose ----

## class ----

#' `StoppingSpecificDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingSpecificDose`] is the class for testing a stopping rule at specific
#' dose of the dose grid and not at the next best dose.
#'
#' @slot rule (`Stopping`)\cr a stopping rule available in this package.
#' @slot dose (`positive_number`)\cr a dose that is defined as part of the dose
#'   grid of the data.
#'
#' @aliases StoppingSpecificDose
#' @export
#'
.StoppingSpecificDose <- setClass(
  Class = "StoppingSpecificDose",
  slots = c(
    rule = "Stopping",
    dose = "positive_number"
  ),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingSpecificDose-class
#'
#' @param rule (`Stopping`)\cr see slot definition.
#' @param dose (`number`)\cr see slot definition.
#' @param report_label (`string` or `NA`) \cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingSpecificDose.R
#'
StoppingSpecificDose <- function(rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
                                 dose = 80,
                                 report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste0("Dose ", dose, " used for testing a stopping rule")
  )

  .StoppingSpecificDose(
    rule = rule,
    dose = positive_number(dose),
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingSpecificDose-class
#' @note Typically, end users will not use the `.DefaultStoppingSpecificDose()` function.
#' @export
.DefaultStoppingSpecificDose <- function() {
  StoppingSpecificDose(
    rule = StoppingTargetProb(target = c(0, 0.3), prob = 0.8),
    dose = positive_number(80)
  )
}

# StoppingHighestDose ----

## class ----

#' `StoppingHighestDose`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingHighestDose`] is the class for stopping based on the highest dose.
#' That is, the stopping occurs when the highest dose is reached.
#'
#' @aliases StoppingHighestDose
#' @export
#'
.StoppingHighestDose <- setClass(
  Class = "StoppingHighestDose",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingHighestDose-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingHighestDose.R
#'
StoppingHighestDose <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    "NBD is the highest dose"
  )

  .StoppingHighestDose(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingHighestDose-class
#' @note Typically, end users will not use the `.DefaultStoppingHighestDose()` function.
#' @export
.DefaultStoppingHighestDose <- function() {
  StoppingHighestDose()
}

# StoppingTDCIRatio ----

## class ----

#' `StoppingTDCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingTDCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`).
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingTDCIRatio
#' @export
#'
.StoppingTDCIRatio <- setClass(
  Class = "StoppingTDCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingTDCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingTDCIRatio.R
#'
StoppingTDCIRatio <- function(target_ratio = 5,
                              prob_target = 0.3,
                              report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("TD", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingTDCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingTDCIRatio-class
#' @note Typically, end users will not use the `.DefaultStoppingTDCIRatio()` function.
#' @export
.DefaultStoppingTDCIRatio <- function() {
  StoppingTDCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}

# StoppingMaxGainCIRatio ----

## class ----

#' `StoppingMaxGainCIRatio`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingMaxGainCIRatio`] is the class for testing a stopping rule that is based
#' on a target ratio of the 95% credibility interval. Specifically, this is the
#' ratio of the upper to the lower bound of the 95% credibility interval's
#' estimate of the:
#' (1) target dose (i.e. a dose that corresponds to a given target
#' probability of the occurrence of a DLT `prob_target`), or
#' (2) max gain dose (i.e. a dose which gives the maximum gain),
#' depending on which one out of these two is smaller.
#'
#' @slot target_ratio (`numeric`)\cr target for the ratio of the 95% credibility
#'   interval's estimate, that is required to stop a trial.
#' @slot prob_target (`proportion`)\cr the target probability of the occurrence
#'   of a DLT.
#'
#' @aliases StoppingMaxGainCIRatio
#' @export
#'
.StoppingMaxGainCIRatio <- setClass(
  Class = "StoppingMaxGainCIRatio",
  slots = c(
    target_ratio = "numeric",
    prob_target = "numeric"
  ),
  prototype = prototype(
    target_ratio = 5,
    prob_target = 0.3
  ),
  contains = "Stopping",
  validity = v_stopping_tdci_ratio
)

## constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#'
#' @param target_ratio (`numeric`)\cr see slot definition.
#' @param prob_target (`proportion`)\cr see slot definition.
#' @param report_label (`string` or `NA`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingMaxGainCIRatio.R
#'
StoppingMaxGainCIRatio <- function(target_ratio = 5,
                                   prob_target = 0.3,
                                   report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("GStar", target_ratio, "for", prob_target, "target prob")
  )

  .StoppingMaxGainCIRatio(
    target_ratio = target_ratio,
    prob_target = prob_target,
    report_label = report_label
  )
}


## default constructor ----

#' @rdname StoppingMaxGainCIRatio-class
#' @examples
#' .DefaultStoppingMaxGainCIRatio()
#' @export
.DefaultStoppingMaxGainCIRatio <- function() {
  StoppingMaxGainCIRatio(
    target_ratio = 5,
    prob_target = 0.3
  )
}

# StoppingList ----

## class ----

#' `StoppingList`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingList`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' The `summary` slot stores a function that takes a logical vector of the size
#' of `stop_list` and returns a single logical value. For example, if the function
#' `all` is specified as a `summary` function, then that all stopping rules
#' defined in `stop_list` must be satisfied in order the result of this rule to
#' be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot summary (`function`)\cr a summary function to combine the results of
#'   the stopping rules into a single result.
#'
#' @aliases StoppingList
#' @export
#'
.StoppingList <- setClass(
  Class = "StoppingList",
  slots = c(
    stop_list = "list",
    summary = "function"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5)),
    summary = all
  ),
  contains = "Stopping",
  validity = v_stopping_list
)

## constructor ----

#' @rdname StoppingList-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param summary (`function`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingList.R
#'
StoppingList <- function(stop_list, summary) {
  .StoppingList(
    stop_list = stop_list,
    summary = summary
  )
}

## default constructor ----

#' @rdname StoppingList-class
#' @note Typically, end users will not use the `.DefaultStoppingList()` function.
#' @export
.DefaultStoppingList <- function() {
  StoppingList(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    ),
    summary = any
  )
}

# StoppingAll ----

## class ----

#' `StoppingAll`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAll`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' All single stopping rules must be satisfied in order the result of this rule
#' to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#' @aliases StoppingAll
#' @export
#'
.StoppingAll <- setClass(
  Class = "StoppingAll",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(
      StoppingMinPatients(50),
      StoppingMinCohorts(5)
    )
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAll-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`) \cr see slot definition.
#' @export
#' @example examples/Rules-class-StoppingAll.R
#'
StoppingAll <- function(stop_list, report_label = NA_character_) {
  .StoppingAll(
    stop_list = stop_list,
    report_label = report_label
  )
}
## default constructor ----

#' @rdname StoppingAll-class
#' @note Typically, end users will not use the `.DefaultStoppingAll()` function.
#' @export
.DefaultStoppingAll <- function() {
  StoppingAll(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingAny ----

## class ----

#' `StoppingAny`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`StoppingAny`] is the class for testing a stopping rule that consists of
#' many single stopping rules that are in turn the objects of class `Stopping`.
#' At least one single stopping rule must be satisfied in order the result of
#' this rule to be `TRUE`.
#'
#' @slot stop_list (`list`)\cr list of stopping rules.
#' @slot report_label label for reporting
#'
#' @aliases StoppingAny
#' @export
#'
.StoppingAny <- setClass(
  Class = "StoppingAny",
  slots = c(
    stop_list = "list"
  ),
  prototype = prototype(
    stop_list = list(StoppingMinPatients(50), StoppingMinCohorts(5))
  ),
  contains = "Stopping",
  validity = v_stopping_all
)

## constructor ----

#' @rdname StoppingAny-class
#'
#' @param stop_list (`list`)\cr see slot definition.
#' @param report_label (`string`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-StoppingAny.R
#'
StoppingAny <- function(stop_list, report_label = NA_character_) {
  .StoppingAny(
    stop_list = stop_list,
    report_label = report_label
  )
}

## default constructor ----

#' @rdname StoppingAny-class
#' @note Typically, end users will not use the `.DefaultStoppingAny()` function.
#' @export
.DefaultStoppingAny <- function() {
  StoppingAny(
    stop_list = c(
      StoppingMinCohorts(nCohorts = 3L),
      StoppingTargetProb(target = c(0.2, 0.35), prob = 0.5),
      StoppingMinPatients(nPatients = 20L)
    )
  )
}

# StoppingOrdinal ----

## class ----

#' `StoppingOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingOrdinal`] is the class for stopping based on a Stopping rule applied
#' to a specific toxicity grade in an ordinal CRM trial
#'
#' @slot grade (`integer`)\cr the grade to which the rule should be applied
#' @slot rule (`Stopping`)\cr the rule to apply
#'
#' @aliases StoppingOrdinal
#' @export
#'
.StoppingOrdinal <- setClass(
  Class = "StoppingOrdinal",
  slots = c(grade = "integer", rule = "Stopping"),
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingOrdinal-class
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`Stopping`)\cr see slot definition.
#' @example examples/Rules-class-StoppingOrdinal.R
#' @export
#'
StoppingOrdinal <- function(grade, rule) {
  .StoppingOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname StoppingOrdinal-class
#' @note Typically, end users will not use the `.DefaultStoppingOrdinal()` function.
#' @export
#'
.DefaultStoppingOrdinal <- function() {
  StoppingOrdinal(
    1L,
    StoppingTargetProb(target = c(0.2, 0.35), prob = 0.6)
  )
}

# StoppingExternal ----

## class ----

#' `StoppingExternal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`StoppingExternal`] is the class for stopping based on an external flag.
#'
#' @aliases StoppingExternal
#' @export
#'
.StoppingExternal <- setClass(
  Class = "StoppingExternal",
  contains = "Stopping"
)

## constructor ----

#' @rdname StoppingExternal-class
#' @param report_label (`string` or `NA`)\cr see slot definition.
#' @example examples/Rules-class-StoppingExternal.R
#' @export
#'
StoppingExternal <- function(report_label = NA_character_) {
  report_label <- h_default_if_empty(
    as.character(report_label),
    paste("Stopped because of external flag")
  )
  .StoppingExternal(report_label = report_label)
}

## default constructor ----

#' @rdname StoppingExternal-class
#' @note Typically, end users will not use the `.DefaultStoppingExternal()` function.
#' @export
#'
.DefaultStoppingExternal <- StoppingExternal

# CohortSize ----

## class ----

#' `CohortSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSize`] is a class for cohort sizes.
#'
#' @seealso [`CohortSizeRange`], [`CohortSizeDLT`], [`CohortSizeConst`],
#'   [`CohortSizeParts`], [`CohortSizeMin`], [`CohortSizeMin`].
#'
#' @aliases CohortSize
#' @export
#'
setClass(
  Class = "CohortSize",
  contains = "CrmPackClass"
)

## default constructor

#' @rdname CohortSize-class
#' @note Typically, end users will not use the `DefaultCohortSize()` function.
#' @export
.DefaultCohortSize <- function() {
  stop(paste0("Class CohortSize should not be instantiated directly.  Please use one of its subclasses instead."))
}

# CohortSizeRange ----

## class ----

#' `CohortSizeRange`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeRange`] is the class for cohort size based on dose range.
#'
#' @slot intervals (`numeric`)\cr a vector with the left bounds of the relevant
#'   dose intervals.
#' @slot cohort_size (`integer`)\cr an integer vector with the cohort sizes
#'   corresponding to the elements of `intervals`.
#'
#' @aliases CohortSizeRange
#' @export
#'
.CohortSizeRange <- setClass(
  Class = "CohortSizeRange",
  slots = c(
    intervals = "numeric",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0, 20),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_range
)

## constructor ----

#' @rdname CohortSizeRange-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeRange.R
#'
CohortSizeRange <- function(intervals, cohort_size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeRange(
    intervals = intervals,
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeRange-class
#' @note Typically, end users will not use the `.DefaultCohortSizeRange()` function.
#' @export
.DefaultCohortSizeRange <- function() {
  CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
}

# CohortSizeDLT ----

## class ----

#' `CohortSizeDLT`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeDLT`] is the class for cohort size based on number of DLTs.

#' @slot intervals (`integer`)\cr a vector with the left bounds of the
#'   relevant DLT intervals.
#' @slot cohort_size (`integer`)\cr a vector with the cohort sizes corresponding
#'   to the elements of `intervals`.
#'
#' @aliases CohortSizeDLT
#' @export
#'
.CohortSizeDLT <- setClass(
  Class = "CohortSizeDLT",
  slots = c(
    intervals = "integer",
    cohort_size = "integer"
  ),
  prototype = prototype(
    intervals = c(0L, 1L),
    cohort_size = c(1L, 3L)
  ),
  contains = "CohortSize",
  validity = v_cohort_size_dlt
)

## constructor ----

#' @rdname CohortSizeDLT-class
#'
#' @param intervals (`numeric`)\cr see slot definition.
#' @param cohort_size (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeDLT.R
#'
CohortSizeDLT <- function(intervals, cohort_size) {
  assert_integerish(intervals, lower = 0, any.missing = FALSE)
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_size, lower = 0, any.missing = FALSE)

  .CohortSizeDLT(
    intervals = as.integer(intervals),
    cohort_size = as.integer(cohort_size)
  )
}

## default constructor ----

#' @rdname CohortSizeDLT-class
#' @note Typically, end users will not use the `.DefaultCohortSizeDLT()` function.
#' @export
.DefaultCohortSizeDLT <- function() {
  CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
}


# CohortSizeConst ----

## class ----

#' `CohortSizeConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeConst`] is the class for fixed and constant size of cohort.
#'
#' @slot size (`integer`)\cr cohort size.
#'
#' @aliases CohortSizeConst
#' @export
#'
.CohortSizeConst <- setClass(
  Class = "CohortSizeConst",
  slots = c(size = "integer"),
  prototype = prototype(size = 3L),
  contains = "CohortSize",
  validity = v_cohort_size_const
)

## constructor ----

#' @rdname CohortSizeConst-class
#'
#' @param size (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeConst.R
#'
CohortSizeConst <- function(size) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(size, lower = 0)
  .CohortSizeConst(size = as.integer(size))
}

## default constructor ----

#' @rdname CohortSizeConst-class
#' @note Typically, end users will not use the `.DefaultCohortSizeConst()` function.
#' @export
.DefaultCohortSizeConst <- function() {
  CohortSizeConst(size = 3L)
}

# CohortSizeParts ----

## class ----

#' `CohortSizeParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeParts`] is the class for cohort size that changes for the second
#' part of the dose escalation. It works only in conjunction with [`DataParts`]
#' objects.
#'
#' @slot cohort_sizes (`integer`)\cr a vector of length two with two sizes, one for
#'   part 1, and one for part 2 respectively.
#'
#' @aliases CohortSizeParts
#' @export
#'
.CohortSizeParts <- setClass(
  Class = "CohortSizeParts",
  slots = c(cohort_sizes = "integer"),
  prototype = prototype(cohort_sizes = c(1L, 3L)),
  contains = "CohortSize",
  validity = v_cohort_size_parts
)

## constructor ----

#' @rdname CohortSizeParts-class
#'
#' @param cohort_sizes (`numeric`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeParts.R
#'
CohortSizeParts <- function(cohort_sizes) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integerish(cohort_sizes, lower = 0, any.missing = FALSE)
  .CohortSizeParts(cohort_sizes = as.integer(cohort_sizes))
}

## default constructor ----

#' @rdname CohortSizeParts-class
#' @note Typically, end users will not use the `.DefaultCohortSizeParts()` function.
#' @export
.DefaultCohortSizeParts <- function() {
  CohortSizeParts(cohort_sizes = c(1L, 3L))
}

# CohortSizeMax ----

## class ----

#' `CohortSizeMax`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMax`] is the class for cohort size that is based on maximum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The maximum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMax
#' @export
#'
.CohortSizeMax <- setClass(
  Class = "CohortSizeMax",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
      CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
    )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## default constructor ----

#' @rdname CohortSizeMax-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMax()` function.
#'
#' @export
.DefaultCohortSizeMax <- function() {
  CohortSizeMax(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

## constructor ----

#' @rdname CohortSizeMax-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMax.R
#'
CohortSizeMax <- function(cohort_sizes) {
  .CohortSizeMax(cohort_sizes = cohort_sizes)
}

# CohortSizeMin ----

## class ----

#' `CohortSizeMin`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`CohortSizeMin`] is the class for cohort size that is based on minimum of
#' multiple cohort size rules. The `cohort_sizes` slot stores a set of cohort
#' size rules, which are again the objects of class [`CohortSize`]. The minimum
#' of these individual cohort sizes is taken to give the final cohort size.
#'
#' @slot cohort_sizes (`list`)\cr a list of cohort size rules, i.e. objects
#' of class [`CohortSize`].
#'
#' @aliases CohortSizeMin
#' @export
#'
.CohortSizeMin <- setClass(
  Class = "CohortSizeMin",
  slots = c(cohort_sizes = "list"),
  prototype = prototype(
    cohort_sizes =
      list(
        CohortSizeRange(intervals = c(0, 30), cohort_size = c(1, 3)),
        CohortSizeDLT(intervals = c(0, 1), cohort_size = c(1, 3))
      )
  ),
  contains = "CohortSize",
  validity = v_cohort_size_max
)

## constructor ----

#' @rdname CohortSizeMin-class
#'
#' @param cohort_sizes (`list`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeMin.R
#'
CohortSizeMin <- function(cohort_sizes) {
  .CohortSizeMin(cohort_sizes = cohort_sizes)
}

## default constructor ----

#' @rdname CohortSizeMin-class
#' @note Typically, end users will not use the `.DefaultCohortSizeMin()` function.
#' @export
.DefaultCohortSizeMin <- function() {
  CohortSizeMin(
    cohort_sizes = list(
      CohortSizeRange(intervals = c(0, 10), cohort_size = c(1L, 3L)),
      CohortSizeDLT(intervals = c(0L, 1L), cohort_size = c(1L, 3L))
    )
  )
}

# CohortSizeOrdinal ----

## class ----

#' `CohortSizeOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`CohortSizeOrdinal`] is the class for cohort size for an ordinal CRM trial.
#'
#' @slot grade (`integer`)\cr the grade at which the rule should be applied
#' @slot rule (`CohortSize`)\cr the `CohortSize` rule to apply.
#'
#' @aliases CohortSizeOrdinal
#' @export
#'
.CohortSizeOrdinal <- setClass(
  Class = "CohortSizeOrdinal",
  slots = c(
    grade = "integer",
    rule = "CohortSize"
  ),
  prototype = prototype(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0, 30), cohort_size = c(1L, 3L))
  ),
  contains = "CohortSize",
  validity = v_cohort_size_ordinal
)

## constructor ----

#' @rdname CohortSizeOrdinal-class
#'
#' @param grade (`integer`)\cr see slot definition.
#' @param rule (`CohortSize`)\cr see slot definition.
#'
#' @export
#' @example examples/Rules-class-CohortSizeOrdinal.R
#'
CohortSizeOrdinal <- function(grade, rule) {
  # Cohort size 0 is needed to allow for no-placebo designs
  assert_integer(grade, lower = 1, len = 1)
  assert_class(rule, "CohortSize")

  .CohortSizeOrdinal(grade = grade, rule = rule)
}

## default constructor ----

#' @rdname CohortSizeOrdinal-class
#' @note Typically, end users will not use the `.DefaultCohortSizeOrdinal()` function.
#' @export
.DefaultCohortSizeOrdinal <- function() {
  CohortSizeOrdinal(
    grade = 1L,
    rule = CohortSizeRange(intervals = c(0L, 30L), cohort_size = c(1L, 3L))
  )
}


# SafetyWindow ----

## class ----

#' `SafetyWindow`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindow`] is a class for safety window.
#'
#' @seealso [`SafetyWindowSize`], [`SafetyWindowConst`].
#'
#' @aliases SafetyWindow
#' @export
#'
setClass(
  Class = "SafetyWindow",
  contains = "CrmPackClass"
)

## default constructor ----

#' @rdname SafetyWindow-class
#' @note Typically, end users will not use the `.DefaultSafetyWindow()` function.
#' @export
.DefaultSafetyWindow <- function() {
  stop(paste0("Class SafetyWindow cannot be instantiated directly.  Please use one of its subclasses instead."))
}


# SafetyWindowSize ----

## class ----

#' `SafetyWindowSize`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowSize`] is the class for safety window length based on cohort
#' size. This class is used to decide the rolling rule from the clinical
#' perspective.
#'
#' @slot gap (`list`)\cr observed period of the previous patient before
#'   the next patient can be dosed. This is used as follows. If for instance,
#'   the cohort size is 4 and we want to specify three time intervals between
#'   these four consecutive patients, i.e. 7 units of time between the 1st and
#'   the 2nd patient, 5 units between the 2nd and the 3rd one, and finally 3
#'   units between the 3rd and the 4th one, then,
#'   `gap` = `list(c(7L, 5L, 3L))`. Sometimes, we want that the interval
#'   only between the 1st and 2nd patient should be increased for the
#'   safety consideration and the rest time intervals should remain constant,
#'   regardless of what the cohort size is. Then, `gap` = `list(c(7L, 3L))`
#'   and the the package will automatically repeat the last element of the vector
#'   for the remaining time intervals.
#' @slot size (`integer`)\cr a vector with the left bounds of the
#'   relevant cohort size intervals. This is used as follows. For instance, when
#'   we want to change the `gap` based on the cohort size, i.e. the time
#'   interval between the 1st and 2nd patient = 9 units of time and the rest
#'   time intervals are of 5 units of time when the cohort size is equal to or
#'   larger than 4. And the time interval between the 1st and 2nd patient = 7 units
#'   of time and the rest time intervals are 3 units of time when the cohort size
#'   is smaller than 4, then we specify `size = c(0L, 4L)`. This means,
#'   the right bound of the intervals are exclusive to the interval, and the
#'   last interval goes from the last value until infinity.
#' @slot follow (`count`)\cr the period of time that each patient in the
#'   cohort needs to be followed before the next cohort opens.
#' @slot follow_min (`count`)\cr at least one patient in the cohort needs
#'   to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowSize
#' @export
#'
.SafetyWindowSize <- setClass(
  Class = "SafetyWindowSize",
  slots = c(
    gap = "list",
    size = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = list(1:2, 1:2),
    size = c(1L, 3L),
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_size
)

## constructor ----

#' @rdname SafetyWindowSize-class
#'
#' @param gap see slot definition.
#' @param size see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowSize.R
#'
SafetyWindowSize <- function(gap,
                             size,
                             follow,
                             follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  for (g in gap) {
    assert_integerish(g, lower = 0)
  }
  assert_integerish(size, lower = 0)
  if (follow > follow_min) {
    warning("The value of follow_min is typically larger than the value of follow")
  }
  gap <- lapply(gap, as.integer)
  .SafetyWindowSize(
    gap = gap,
    size = as.integer(size),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowSize-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowSize()` function.
#' @export
.DefaultSafetyWindowSize <- function() {
  SafetyWindowSize(
    gap = list(c(7, 3), c(9, 5)),
    size = c(1, 4),
    follow = 7,
    follow_min = 14
  )
}

# SafetyWindowConst ----

## class ----

#' `SafetyWindowConst`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`SafetyWindowConst`] is the class for safety window length and it is used
#' when the `gap` should be kept constant.
#'
#' @slot gap (`integer`)\cr a vector, the constant gap between patients.
#' @slot follow (`count`)\cr how long to follow each patient. The period of time
#'   that each patient in the cohort needs to be followed before the next cohort
#'   opens.
#' @slot follow_min (`count`)\cr minimum follow up. At least one patient in the
#'   cohort needs to be followed at the minimal follow up time.
#'
#' @aliases SafetyWindowConst
#' @export
#'
.SafetyWindowConst <- setClass(
  Class = "SafetyWindowConst",
  slots = c(
    gap = "integer",
    follow = "integer",
    follow_min = "integer"
  ),
  prototype = prototype(
    gap = 0L,
    follow = 1L,
    follow_min = 1L
  ),
  contains = "SafetyWindow",
  validity = v_safety_window_const
)

## constructor ----

#' @rdname SafetyWindowConst-class
#'
#' @param gap see slot definition.
#' @param follow see slot definition.
#' @param follow_min see slot definition.
#'
#' @export
#' @example examples/Rules-class-SafetyWindowConst.R
#'
SafetyWindowConst <- function(gap,
                              follow,
                              follow_min) {
  assert_integerish(follow, lower = 0)
  assert_integerish(follow_min, lower = 0)
  assert_integerish(gap, lower = 0)

  if (follow > follow_min) {
    warning("The value of follow_min is typically larger than the value of follow")
  }
  .SafetyWindowConst(
    gap = as.integer(gap),
    follow = as.integer(follow),
    follow_min = as.integer(follow_min)
  )
}

## default constructor ----

#' @rdname SafetyWindowConst-class
#' @note Typically, end users will not use the `.DefaultSafetyWindowConst()` function.
#' @export
.DefaultSafetyWindowConst <- function() {
  SafetyWindowConst(
    gap = c(7, 5, 3),
    follow = 7,
    follow_min = 14
  )
}

#' @include Data-methods.R
#' @include Design-class.R
#' @include McmcOptions-class.R
#' @include Rules-methods.R
#' @include Simulations-class.R
#' @include helpers.R
#' @include mcmc.R
NULL

# nolint start

## ============================================================

##' Simulate outcomes from a CRM design
##'
##' @param object the \code{\linkS4class{Design}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{Simulations}}
##'
##' @example examples/design-method-simulate-Design.R
##' @export
##' @importFrom parallel detectCores
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "Design",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL, firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5), derive = list(),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample.int(n = 2147483647, size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- h_this_truth(
            object@data@doseGrid[1],
            thisArgs,
            truth
          )
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- h_this_truth(
            thisDose,
            thisArgs,
            truth
          )

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }

          thisData <- h_determine_dlts(
            data = thisData,
            dose = thisDose,
            prob = thisProb,
            prob_placebo = thisProb.PL,
            cohort_size = thisSize,
            cohort_size_placebo = thisSize.PL,
            dose_grid = object@data@doseGrid[1],
            first_separate = firstSeparate
          )

          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = object@model,
            options = mcmcOptions
          )

          ## => what is the next best dose?
          thisDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value


          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )

          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = object@model,
          data = thisData
        )

        # Get the MTD estimate from the samples.

        target_dose_samples <- dose(
          mean(object@nextBest@target),
          model = object@model,
          samples = thisSamples
        )

        # Create a function for additional statistical summary.

        additional_stats <- lapply(derive, function(f) f(target_dose_samples))

        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            fit =
              subset(thisFit,
                select = c(middle, lower, upper)
              ),
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results,
            additional_stats = additional_stats
          )
        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truth",
            "object",
            "mcmcOptions"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      # format simulation output
      simulations_output <- h_simulations_output_format(resultList)

      ## return the results in the Simulations class object
      ret <- Simulations(
        data = simulations_output$dataList,
        doses = simulations_output$recommendedDoses,
        fit = simulations_output$fitList,
        stop_report = simulations_output$stop_matrix,
        stop_reasons = simulations_output$stopReasons,
        additional_stats = simulations_output$additional_stats,
        seed = RNGstate
      )

      return(ret)
    }
)




##' Simulate outcomes from a rule-based design
##'
##' @param object the \code{\linkS4class{RuleDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @return an object of class \code{\linkS4class{GeneralSimulations}}
##'
##' @example examples/design-method-simulate-RuleDesign.R
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "RuleDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL,
             parallel = FALSE,
             nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truth,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## simulate DLTs
          thisDLTs <- rbinom(
            n = thisSize,
            size = 1L,
            prob = thisProb
          )

          ## update the data with this cohort
          thisData <- update(
            object = thisData,
            x = thisDose,
            y = thisDLTs
          )

          ## evaluate the rule
          thisOutcome <- nextBest(object@nextBest,
            data = thisData
          )

          thisDose <- thisOutcome$value
          stopit <- thisOutcome$stopHere
        }

        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose
          )

        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "truth",
            "object"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the GeneralSimulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

      ## return the results in the GeneralSimulations class object
      ret <- GeneralSimulations(
        data = dataList,
        doses = recommendedDoses,
        seed = RNGstate
      )

      return(ret)
    }
)


##' Simulate outcomes from a dual-endpoint design
##'
##' @param object the \code{\linkS4class{DualDesign}} object we want to simulate
##' data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param trueTox a function which takes as input a dose (vector) and returns the
##' true probability (vector) for toxicity. Additional arguments can be supplied
##' in \code{args}.
##' @param trueBiomarker a function which takes as input a dose (vector) and
##' returns the true biomarker level (vector). Additional arguments can be
##' supplied in \code{args}.
##' @param args data frame with arguments for the \code{trueTox} and
##' \code{trueBiomarker} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param sigma2W variance for the biomarker measurements
##' @param rho correlation between toxicity and biomarker measurements (default:
##' 0)
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{DualSimulations}}
##'
##' @example examples/design-method-simulate-DualDesign.R
##' @importFrom mvtnorm rmvnorm
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(object = "DualDesign"),
  def =
    function(object, nsim = 1L, seed = NULL,
             trueTox, trueBiomarker, args = NULL,
             sigma2W, rho = 0,
             firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE,
             nCores =
               min(parallel::detectCores(), 5), derive = list(),
             ...) {
      ## checks and extracts
      assert_function(trueTox)
      assert_function(trueBiomarker)
      assert_number(sigma2W, lower = 0)
      assert_number(rho, lower = -1, upper = 1)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## get names of arguments (excluding the first one which is the dose)
      trueToxArgnames <- names(formals(trueTox))[-1]
      trueBiomarkerArgnames <- names(formals(trueBiomarker))[-1]

      ## this is the covariance matrix we assume:
      trueCov <- matrix(
        c(
          sigma2W, sqrt(sigma2W) * rho,
          sqrt(sigma2W) * rho, 1
        ),
        nrow = 2, byrow = TRUE
      )

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the true functions?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so the true tox function is:
        thisTrueTox <- function(dose) {
          do.call(
            trueTox,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the tox function
              as.list(thisArgs)[trueToxArgnames]
            )
          )
        }

        ## and the true biomarker function is:
        thisTrueBiomarker <- function(dose) {
          do.call(
            trueBiomarker,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the biomarker function
              as.list(thisArgs)[trueBiomarkerArgnames]
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTrueTox(object@data@doseGrid[1])
          thisMeanZ.PL <- qlogis(thisProb.PL)

          ## what is the biomarker mean at placebo?
          thisMeanBiomarker.PL <- thisTrueBiomarker(object@data@doseGrid[1])
        }

        # In case there are placebo, extract true Toxicity and Efficacy for placebo

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTrueTox(thisDose)
          ## and the transformation to the z scale is:
          thisMeanZ <- qlogis(thisProb)

          ## what is the biomarker mean at this dose?
          thisMeanBiomarker <- thisTrueBiomarker(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          ## what is the cohort size at this dose for Placebo?
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }

          ## simulate tox and biomarker response: depends on whether we
          ## separate the first patient or not.
          tmp <-
            if (firstSeparate && (thisSize > 1L)) {
              ## dose the first patient
              tmpStart <- mvtnorm::rmvnorm(
                n = 1,
                mean =
                  c(
                    thisMeanBiomarker,
                    thisMeanZ
                  ),
                sigma = trueCov
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                tmpStart.PL <- mvtnorm::rmvnorm(
                  n = 1,
                  mean =
                    c(
                      thisMeanBiomarker.PL,
                      thisMeanZ.PL
                    ),
                  sigma = trueCov
                )
              }


              ## if there is no DLT:
              if (tmpStart[, 2] < 0) {
                ## enroll the remaining patients
                tmpStart <-
                  rbind(
                    tmpStart,
                    mvtnorm::rmvnorm(
                      n = thisSize - 1,
                      mean =
                        c(
                          thisMeanBiomarker,
                          thisMeanZ
                        ),
                      sigma = trueCov
                    )
                  )

                if (thisData@placebo && (thisSize.PL > 0L)) {
                  tmpStart.PL <-
                    rbind(
                      tmpStart.PL,
                      mvtnorm::rmvnorm(
                        n = thisSize.PL,
                        mean =
                          c(
                            thisMeanBiomarker.PL,
                            thisMeanZ.PL
                          ),
                        sigma = trueCov
                      )
                    )
                }
              }

              if (thisData@placebo && (thisSize.PL > 0L)) {
                list(tmpStart = tmpStart, tmpStart.PL = tmpStart.PL)
              } else {
                list(tmpStart = tmpStart)
              }
            } else {
              ## we can directly dose all patients
              tmpStart <- mvtnorm::rmvnorm(
                n = thisSize,
                mean =
                  c(
                    thisMeanBiomarker,
                    thisMeanZ
                  ),
                sigma = trueCov
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                tmpStart.PL <- mvtnorm::rmvnorm(
                  n = thisSize.PL,
                  mean =
                    c(
                      thisMeanBiomarker.PL,
                      thisMeanZ.PL
                    ),
                  sigma = trueCov
                )
              }

              if (thisData@placebo && (thisSize.PL > 0L)) {
                list(tmpStart = tmpStart, tmpStart.PL = tmpStart.PL)
              } else {
                list(tmpStart = tmpStart)
              }
            }

          ## extract biomarker and DLT samples
          thisBiomarkers <- tmp$tmpStart[, 1]
          thisDLTs <- as.integer(tmp$tmpStart[, 2] > 0)

          # in case there are placebo
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisBiomarkers.PL <- tmp$tmpStart.PL[, 1]
            thisDLTs.PL <- as.integer(tmp$tmpStart.PL[, 2] > 0)

            ## update the data first with placebo...
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL,
              w = thisBiomarkers.PL,
              check = FALSE
            )

            ### ... and then with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisBiomarkers,
              new_cohort = FALSE
            )
          } else {
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisBiomarkers
            )
          }


          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = object@model,
            options = mcmcOptions
          )

          ## => what is the next best dose?
          thisDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = object@model,
          data = thisData
        )

        # Get the MTD estimate from the samples.

        target_dose_samples <- dose(
          mean(object@nextBest@target),
          model = object@model,
          samples = thisSamples
        )

        # Create a function for additional statistical summary.

        additional_stats <- lapply(derive, function(f) f(target_dose_samples))


        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            fitTox =
              subset(thisFit,
                select =
                  c(middle, lower, upper)
              ),
            fit_biomarker =
              subset(thisFit,
                select =
                  c(
                    middleBiomarker, lowerBiomarker,
                    upperBiomarker
                  )
              ),
            rho_est = median(thisSamples@data$rho),
            sigma2w_est = median(1 / thisSamples@data$precW),
            stop =
              attr(
                stopit,
                "message"
              ),
            additional_stats = additional_stats,
            report_results = stopit_results
          )

        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "trueTox",
            "trueBiomarker",
            "trueCov",
            "object",
            "mcmcOptions"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

      ## vector of rho estimates
      rhoEstimates <- as.numeric(sapply(resultList, "[[", "rho_est"))

      ## vector of sigma2W estimates
      sigma2Westimates <- as.numeric(sapply(resultList, "[[", "sigma2w_est"))

      ## setup the list for the final tox fits
      fitToxList <- lapply(resultList, "[[", "fitTox")

      ## setup the list for the final biomarker fits
      fitBiomarkerList <- lapply(resultList, "[[", "fit_biomarker")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))

      ## For dual simulations summary of additional statistics.
      additional_stats <- lapply(resultList, "[[", "additional_stats")

      ## return the results in the DualSimulations class object
      ret <- DualSimulations(
        data = dataList,
        doses = recommendedDoses,
        rho_est = rhoEstimates,
        sigma2w_est = sigma2Westimates,
        fit = fitToxList,
        fit_biomarker = fitBiomarkerList,
        stop_report = stop_report,
        stop_reasons = stopReasons,
        additional_stats = additional_stats,
        seed = RNGstate
      )

      return(ret)
    }
)


## ============================================================

##' Obtain hypothetical trial course table for a design
##'
##' This generic function takes a design and generates a dataframe
##' showing the beginning of several hypothetical trial courses under
##' the design. This means, from the generated dataframe one can read off:
##' - how many cohorts are required in the optimal case (no DLTs observed) in
##'   order to reach the highest dose of the specified dose grid (or until
##'   the stopping rule is fulfilled)
##' - assuming no DLTs are observed until a certain dose level, what the next
##'   recommended dose is for all possible number of DLTs observed
##' - the actual relative increments that will be used in these cases
##' - whether the trial would stop at a certain cohort
##' Examining the "single trial" behavior of a dose escalation design is
##' the first important step in evaluating a design, and cannot be replaced by
##' studying solely the operating characteristics in "many trials". The cohort
##' sizes are also taken from the design, assuming no DLTs occur until the dose
##' listed.
##'
##' @param object the design (\code{\linkS4class{Design}} or
##' \code{\linkS4class{RuleDesign}} object) we want to examine
##' @param \dots additional arguments (see methods)
##' @param maxNoIncrement maximum number of contiguous next doses at 0
##' DLTs that are the same as before, i.e. no increment (default to 100)
##'
##' @return The data frame
##'
##' @export
##' @keywords methods regression
setGeneric("examine",
  def =
    function(object, ..., maxNoIncrement = 100L) {
      ## check maxNoIncrement argument
      assert_count(maxNoIncrement, positive = TRUE)

      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("examine")
    },
  valueClass = "data.frame"
)


##' @describeIn examine Examine a model-based CRM
##'
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##'
##' @example examples/design-method-examine-Design.R
setMethod("examine",
  signature =
    signature(object = "Design"),
  def =
    function(object,
             mcmcOptions = McmcOptions(),
             ...,
             maxNoIncrement) {
      ## start with the empty table
      ret <- data.frame(
        dose = numeric(),
        DLTs = integer(),
        nextDose = numeric(),
        stop = logical(),
        increment = integer()
      )

      ## start the base data with the provided one
      baseData <- object@data

      ## are we finished and can stop?
      stopit <- FALSE

      ## counter how many contiguous doses at 0 DLTs with
      ## no increment
      noIncrementCounter <- 0L

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we continue filling up the table, until
      ## stopping
      while (!stopit) {
        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size,
          dose = thisDose,
          data = baseData
        )

        if (baseData@placebo) {
          thisSize.PL <- size(object@pl_cohort_size,
            dose = thisDose,
            data = baseData
          )
        }

        ## for all possible number of DLTs:
        for (numDLTs in 0:thisSize)
        {
          ## update data with corresponding DLT vector
          if (baseData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = baseData,
              x = baseData@doseGrid[1],
              y = rep(0, thisSize.PL),
              check = FALSE
            )

            thisData <-
              update(
                object = thisData,
                x = thisDose,
                y =
                  rep(
                    x = c(0, 1),
                    times =
                      c(
                        thisSize - numDLTs,
                        numDLTs
                      )
                  ),
                new_cohort = FALSE
              )
          } else {
            thisData <-
              update(
                object = baseData,
                x = thisDose,
                y =
                  rep(
                    x = c(0, 1),
                    times =
                      c(
                        thisSize - numDLTs,
                        numDLTs
                      )
                  )
              )
          }

          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = object@model,
            options = mcmcOptions
          )

          ## => what is the next best dose?
          nextDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value

          ## compute relative increment in percent
          thisIncrement <-
            round((nextDose - thisDose) / thisDose * 100)

          ## evaluate stopping rules
          stopThisTrial <- stopTrial(object@stopping,
            dose = nextDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )

          ## append information to the data frame
          ret <- rbind(
            ret,
            list(
              dose = thisDose,
              DLTs = numDLTs,
              nextDose = nextDose,
              stop = stopThisTrial,
              increment = as.integer(thisIncrement)
            )
          )
        }

        ## change base data
        if (baseData@placebo && (thisSize.PL > 0L)) {
          baseData <-
            update(
              object = baseData,
              x = baseData@doseGrid[1],
              y = rep(0, thisSize.PL),
              check = FALSE
            )

          baseData <-
            update(
              object = baseData,
              x = thisDose,
              y = rep(0, thisSize),
              new_cohort = FALSE
            )
        } else {
          baseData <-
            update(
              object = baseData,
              x = thisDose,
              y = rep(0, thisSize)
            )
        }

        ## what are the results if 0 DLTs?
        resultsNoDLTs <- subset(
          tail(ret, thisSize + 1),
          dose == thisDose & DLTs == 0
        )

        ## what is the new dose then accordingly?
        newDose <- as.numeric(resultsNoDLTs$nextDose)

        ## what is the difference to the previous dose?
        doseDiff <- newDose - thisDose

        ## update the counter for no increments of the dose
        if (doseDiff == 0) {
          noIncrementCounter <- noIncrementCounter + 1L
        } else {
          noIncrementCounter <- 0L
        }

        ## would stopping rule be fulfilled already?
        stopAlready <- resultsNoDLTs$stop

        ## update dose
        thisDose <- newDose

        ## too many times no increment?
        stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
        if (stopNoIncrement) {
          warning(paste(
            "Stopping because",
            noIncrementCounter,
            "times no increment vs. previous dose"
          ))
        }

        ## check if we can stop:
        ## either when we have reached the highest dose in the
        ## next cohort, or when the stopping rule is already
        ## fulfilled, or when too many times no increment
        stopit <- (thisDose >= max(object@data@doseGrid)) ||
          stopAlready || stopNoIncrement
      }

      return(ret)
    }
)



##' @describeIn examine Examine a rule-based design
##' @example examples/design-method-examine-RuleDesign.R
setMethod("examine",
  signature =
    signature(object = "RuleDesign"),
  def =
    function(object,
             ...,
             maxNoIncrement) {
      ## start with the empty table
      ret <- data.frame(
        dose = numeric(),
        DLTs = integer(),
        nextDose = numeric(),
        stop = logical(),
        increment = integer()
      )

      ## start the base data with the provided one
      baseData <- object@data

      ## are we finished and can stop?
      stopit <- FALSE

      ## counter how many contiguous doses at 0 DLTs with
      ## no increment
      noIncrementCounter <- 0L

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## inside this loop we continue filling up the table, until
      ## stopping
      while (!stopit) {
        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size,
          dose = thisDose,
          data = baseData
        )

        ## for all possible number of DLTs:
        for (numDLTs in 0:thisSize)
        {
          ## update data with corresponding DLT vector
          thisData <-
            update(
              object = baseData,
              x = thisDose,
              y =
                rep(
                  x = c(0, 1),
                  times =
                    c(
                      thisSize - numDLTs,
                      numDLTs
                    )
                )
            )

          ## evaluate the rule
          thisOutcome <- nextBest(object@nextBest,
            data = thisData
          )

          ## next dose
          nextDose <- thisOutcome$value

          ## do we stop here?
          stopThisTrial <- thisOutcome$stopHere

          ## compute relative increment in percent
          thisIncrement <-
            round((nextDose - thisDose) / thisDose * 100)

          ## append information to the data frame
          ret <- rbind(
            ret,
            list(
              dose = thisDose,
              DLTs = numDLTs,
              nextDose = nextDose,
              stop = stopThisTrial,
              increment = as.integer(thisIncrement)
            )
          )
        }

        ## change base data
        baseData <-
          update(
            object = baseData,
            x = thisDose,
            y = rep(0, thisSize)
          )

        ## what are the results if 0 DLTs?
        resultsNoDLTs <- subset(
          tail(ret, thisSize + 1),
          dose == thisDose & DLTs == 0
        )

        ## what is the new dose then accordingly?
        newDose <- as.numeric(resultsNoDLTs$nextDose)

        ## what is the difference to the previous dose?
        doseDiff <- newDose - thisDose

        ## update the counter for no increments of the dose
        if (doseDiff == 0) {
          noIncrementCounter <- noIncrementCounter + 1L
        } else {
          noIncrementCounter <- 0L
        }

        ## would stopping rule be fulfilled already?
        stopAlready <- resultsNoDLTs$stop

        ## update dose
        thisDose <- newDose

        ## too many times no increment?
        stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
        if (stopNoIncrement) {
          warning(paste(
            "Stopping because",
            noIncrementCounter,
            "times no increment vs. previous dose"
          ))
        }

        ## check if we can stop:
        ## either when we have reached the highest dose in the
        ## next cohort, or when the stopping rule is already
        ## fulfilled, or when too many times no increment
        stopit <- (thisDose >= max(object@data@doseGrid)) ||
          stopAlready || stopNoIncrement
      }

      return(ret)
    }
)

##' @describeIn examine Examine a model-based CRM
##'
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##'
##' @example examples/design-method-examine-DADesign.R
setMethod("examine",
  signature =
    signature(object = "DADesign"),
  def =
    function(object, mcmcOptions = McmcOptions(), ...,
             maxNoIncrement) {
      # A function to return follow up fulfull yes (TRUE) vs no (FALSE);
      ready_to_open <- function(day, window, thisSurv) {
        size <- length(thisSurv)
        # the date the patient starts;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # the relative time for each patient on the specified "date";
        individule_check <- day - cumsum(c(0, start_time))
        # the minial number should be 0;
        individule_check[individule_check < 0] <- 0
        follow_up <- apply(rbind(thisSurv, individule_check), 2, min)
        return(all((follow_up - apply(rbind(window$patientFollow, thisSurv), 2, min)) >= 0) & (max(follow_up) >= min(window$patientFollowMin, max(thisSurv))))
      }

      ## assume we have surfficient patients, i.e. patient can be immediately enrolled
      ## once the trial accumulation is open. This function will tell you when to open
      ## the next cohort;
      # this function applys to all trials;
      nextOpen <- function(window, thisSurv) {
        size <- length(thisSurv)

        window$patientGap <- window$patientGap[1:size] ## if length(window$pt)>length(thisSurv), assume the first length(thisSurv) patients were enrolled;
        ## if the DLT happens before the end of DLT window, then the next
        ## cohort/enrollment of the next patient would happened earlier;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # duration of the cohort (all DLT windows finished);
        maxT <- max(thisSurv + cumsum(c(0, start_time)))

        meetrequire <- sapply(1:maxT, function(i) {
          ready_to_open(i, window, thisSurv)
        })
        if (sum(meetrequire) > 0) {
          # the earliest time that the require is met;
          time <- min(c(1:maxT)[meetrequire])
        } else {
          time <- maxT
        }

        return(time)
      }

      ## start with the empty table
      ret <- data.frame(
        DLTsearly_1 = integer(), ## JZ: add a cohort index;
        dose = numeric(),
        DLTs = integer(),
        nextDose = numeric(),
        stop = logical(),
        increment = integer()
      )

      ## start the base data with the provided one
      baseData <- object@data

      ## are we finished and can stop?
      stopit <- FALSE

      ## what is the next dose to be used?
      ## initialize with starting dose
      thisDose <- object@startingDose

      ## initial {fact} variables;
      factDLTs <- baseData@y
      factSurv <- baseData@u
      factT0 <- baseData@t0

      ## Initiate "trialtime" which is zero. This is the global time for studies;
      trialtime <- 0

      ## when the current cohort open?
      pretime <- 0

      ## the duration of DLT window
      Tmax <- baseData@Tmax

      ## number of patients with un-completed DLT window;
      ## assume no patient is under DLT observation period at the beginning;
      preSize <- 0

      ## inside this loop we continue filling up the table, until
      ## stopping
      while (!stopit) {
        ## what is the cohort size at this dose?
        thisSize <- size(object@cohort_size,
          dose = thisDose,
          data = baseData
        )

        ## what's the safetywindow
        thisSafetywindow <- windowLength(object@safetyWindow, thisSize)


        # initial parameters
        thisT0 <- trialtime + cumsum(thisSafetywindow$patientGap)

        factDLTs <- c(factDLTs, rep(0, thisSize))

        factSurv <- c(factSurv, rep(Tmax, thisSize))

        factT0 <- c(factT0, thisT0)

        ## The time that the next cohort open
        trialtime <- trialtime + nextOpen(
          window = thisSafetywindow,
          thisSurv = rep(Tmax, thisSize)
        )

        ## In the DA-CRM, we should count the number of patients who is still within the DLT window;
        ## Thus the loop for numDLTs should be 0:nFollow;
        nFollow <- thisSize + preSize

        ## Identify the censored patients;
        ## "thiscensored" will be used in the cases that numDLTs>0;
        npt <- length(baseData@x) # total number of patients

        thiscensored <- c(c(1:npt)[(trialtime - baseData@t0) < baseData@Tmax & baseData@y == 0], (npt + 1):(npt + thisSize))



        ## for all possible number of DLTs:
        for (numDLTs in 0:nFollow)
        {
          ## If numDLTs>0, two extreme cases will be examinated;
          ## (1) DLTs occur on patients with the longer follow ups;
          ## (2) DLTs occur on patients with the shorter follow ups;






          if (numDLTs == 0) {
            baseData <- update(
              object = baseData,
              y = factDLTs, #### the x will be constantly updated according to u
              u = factSurv,
              t0 = factT0,
              x = thisDose,
              trialtime = trialtime
            ) #### the u will be constantly updated



            ## what is the dose limit?
            doselimit <- maxDose(object@increments,
              data = baseData
            )

            ## generate samples from the model
            thisSamples <- mcmc(
              data = baseData,
              model = object@model,
              options = mcmcOptions
            )

            ## => what is the next best dose?
            nextDose <- nextBest(object@nextBest,
              doselimit = doselimit,
              samples = thisSamples,
              model = object@model,
              data = baseData
            )$value

            # ##remove savePlot
            #
            #                                                   savePlot(plot(baseData),name=paste("Dose",thisDose,0,"DLT",nextDose,sep="_"))
            #
            ## compute relative increment in percent
            thisIncrement <-
              round((nextDose - thisDose) / thisDose * 100)

            ## evaluate stopping rules
            stopThisTrial <- stopTrial(object@stopping,
              dose = nextDose,
              samples = thisSamples,
              model = object@model,
              data = baseData
            )

            ## append information to the data frame
            ret <- rbind(
              ret,
              list(
                DLTsearly_1 = 0,
                dose = thisDose,
                DLTs = numDLTs,
                nextDose = nextDose,
                stop = stopThisTrial,
                increment = as.integer(thisIncrement)
              )
            )
            ### comment here to show only no DLTs;
            #                                            }
          } else {
            for (DLTsearly in 1:numDLTs) {
              # Update current {fact} variables
              thisDLTs <- factDLTs
              thisSurv <- factSurv

              if (DLTsearly == 1) {
                # scenario 1: The patients with longest follow up have DLTs

                thisDLTs[thiscensored][1:numDLTs] <- rep(1, rep(numDLTs))

                thisSurv[thiscensored][1:numDLTs] <- apply(rbind(rep(Tmax, numDLTs), c(trialtime - factT0[thiscensored][1:numDLTs])), 2, min)


                thisData <- update(
                  object = baseData,
                  y = thisDLTs, #### the y will be updated according to u
                  u = thisSurv,
                  t0 = factT0,
                  x = thisDose,
                  trialtime = trialtime
                ) #### the u will be updated
              } else {
                # scenario 2: The patients with shortest follow up have DLTs

                thisDLTs[rev(thiscensored)][1:numDLTs] <- rep(1, rep(numDLTs))

                thisSurv[rev(thiscensored)][1:numDLTs] <- c(apply(rbind(rep(1, numDLTs), pretime + 1 - factT0[rev(thiscensored)][1:numDLTs]), 2, max))

                if (numDLTs >= thisSize) {
                  thistime <- 1 + max(thisT0)
                } else {
                  thistime <- trialtime
                }

                thisData <- update(
                  object = baseData,
                  y = thisDLTs, #### the y will be updated according to u
                  u = thisSurv,
                  t0 = factT0,
                  x = thisDose,
                  trialtime = thistime
                ) #### the u will be updated
              }


              ## what is the dose limit?
              doselimit <- maxDose(object@increments,
                data = thisData
              )

              ## generate samples from the model
              thisSamples <- mcmc(
                data = thisData,
                model = object@model,
                options = mcmcOptions
              )

              ## => what is the next best dose?
              nextDose <- nextBest(object@nextBest,
                doselimit = doselimit,
                samples = thisSamples,
                model = object@model,
                data = thisData
              )$value

              # ##remove savePlot
              #                                                   savePlot(plot(thisData),name=paste("Dose",thisDose,numDLTs,"DLT",DLTsearly,nextDose,sep="_"))
              #
              ## compute relative increment in percent
              thisIncrement <-
                round((nextDose - thisDose) / thisDose * 100)

              ## evaluate stopping rules
              stopThisTrial <- stopTrial(object@stopping,
                dose = nextDose,
                samples = thisSamples,
                model = object@model,
                data = thisData
              )

              ## append information to the data frame
              ret <- rbind(
                ret,
                list(
                  DLTsearly_1 = DLTsearly,
                  dose = thisDose,
                  DLTs = numDLTs,
                  nextDose = nextDose,
                  stop = stopThisTrial,
                  increment = as.integer(thisIncrement)
                )
              )
            }
          }
        }

        ## update pretime
        pretime <- trialtime

        ## what are the results if 0 DLTs?
        resultsNoDLTs <- subset(
          ret,
          dose == thisDose & DLTs == 0
        )

        ## what is the new dose according to table?
        newDose <- as.numeric(resultsNoDLTs$nextDose)

        ## what is the difference to the previous dose?
        doseDiff <- newDose - thisDose

        ## would stopping rule be fulfilled already?
        stopAlready <- any(resultsNoDLTs$stop)

        ## update dose
        thisDose <- max(newDose)

        ## number of patients with un-completed DLT window;
        preSize <- sum(baseData@u[baseData@y == 0] < baseData@Tmax)

        ## update the counter for no increments of the dose
        if (all(doseDiff == 0)) {
          noIncrementCounter <- noIncrementCounter + 1L
        } else {
          noIncrementCounter <- 0L
        }

        ## too many times no increment?
        stopNoIncrement <- (noIncrementCounter >= maxNoIncrement)
        if (stopNoIncrement) {
          warning(paste(
            "Stopping because",
            noIncrementCounter,
            "times no increment vs. previous dose"
          ))
        }

        ## check if we can stop:
        ## either when we have reached the highest dose in the
        ## next cohort, or when the stopping rule is already
        ## fulfilled, or when too many times no increment
        stopit <- (thisDose >= max(object@data@doseGrid)) ||
          stopAlready || stopNoIncrement
      }

      return(ret)
    }
)

## ===================================================================================
## ----------------------------------------------------------------------------------------
##  Simulate design using DLE responses only with DLE samples (pseudo DLE model)
## ------------------------------------------------------------------------------------
##' This is a methods to simulate dose escalation procedure only using the DLE responses.
##' This is a method based on the \code{\linkS4class{TDsamplesDesign}} where model used are of
##' \code{\linkS4class{ModelTox}} class object DLE samples are also used
##'
##' @param object the \code{\linkS4class{TDsamplesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateTDsamplesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoSimulations}}
##'
##'  @export
##'  @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "TDsamplesDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL, firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)


      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truth,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruth(object@data@doseGrid[1])
        }


        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)


          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }



          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisProb
                )
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisProb
            )
            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs
            )
          }

          ## Update the model with thisData
          thisModel <- update(object@model,
            data = thisData
          )

          ## what is the dose limit?
          doselimit <- maxDose(object@increments,
            data = thisData
          )

          ## generate samples from the model
          thisSamples <- mcmc(
            data = thisData,
            model = thisModel,
            options = mcmcOptions
          )

          ## => what is the next best dose?

          next_bd <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = thisModel,
            data = thisData,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose_drt
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialatdoseGrid <- next_bd$next_dose_eot
          thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = thisModel,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = thisModel,
          data = thisData
        )


        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            TDtargetDuringTrial = thisTDtargetDuringTrial,
            TDtargetEndOfTrial = thisTDtargetEndOfTrial,
            TDtargetEndOfTrialatdoseGrid = thisTDtargetEndOfTrialatdoseGrid,
            TDtargetDuringTrialatdoseGrid = thisDose,
            CITDEOT = thisCITDEOT,
            ratioTDEOT = thisratioTDEOT,
            fit =
              subset(thisFit,
                select = c(middle, lower, upper)
              ),
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results
          )
        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truth",
            "object",
            "mcmcOptions"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialatdoseGrid"))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))


      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final TDEOT 95% CI obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final TDEOT ratios obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## setup the list for the final fits
      fitList <- lapply(resultList, "[[", "fit")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))


      ## return the results in the Simulations class object
      ret <- PseudoSimulations(
        data = dataList,
        doses = recommendedDoses,
        fit = fitList,
        final_td_target_during_trial_estimates = TDtargetDuringTrialList,
        final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
        final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
        final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
        final_cis = CIList,
        final_ratios = ratioList,
        final_tdeot_cis = CITDEOTList,
        final_tdeot_ratios = ratioTDEOTList,
        stop_reasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )

      return(ret)
    }
)
## -------------------------------------------------------------------------------------
## Simulate design using DLE responses only without samples (pseudo DLE model)
## --------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure only using the DLE responses.
##' This is a method based on the \code{\linkS4class{TDDesign}} where model used are of
##' \code{\linkS4class{ModelTox}} class object and no samples are involved.
##'
##' @param object the \code{\linkS4class{TDDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param truth a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param args data frame with arguments for the \code{truth} function. The
##' column names correspond to the argument names, the rows to the values of the
##' arguments. The rows are appropriately recycled in the \code{nsim}
##' simulations. In order to produce outcomes from the posterior predictive
##' distribution, e.g, pass an \code{object} that contains the data observed so
##' far, \code{truth} contains the \code{prob} function from the model in
##' \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateTDDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoSimulations}}
##'
##'  @export
##'  @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "TDDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truth, args = NULL, firstSeparate = FALSE,
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(truth)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truth,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruth(object@data@doseGrid[1])
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }

          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisProb
                )
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs
            )
          }

          ## Update model estimates with thisData
          thisModel <- update(object@model,
            data = thisData
          )

          ## what is the dose limit?
          doselimit <- maxDose(object@increments, data = thisData)


          ## => what is the next best dose?
          next_bd <- nextBest(object@nextBest,
            doselimit = doselimit,
            model = thisModel,
            data = thisData,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose_drt
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialatdoseGrid <- next_bd$next_dose_eot
          thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            model = thisModel,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }
        ## get the fit
        prob_fun <- probFunction(thisModel, phi1 = thisModel@phi1, phi2 = thisModel@phi2)
        thisFit <- list(
          phi1 = thisModel@phi1,
          phi2 = thisModel@phi2,
          probDLE = prob_fun(object@data@doseGrid)
        )



        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            TDtargetDuringTrial = thisTDtargetDuringTrial,
            TDtargetEndOfTrial = thisTDtargetEndOfTrial,
            TDtargetEndOfTrialatdoseGrid = thisTDtargetEndOfTrialatdoseGrid,
            TDtargetDuringTrialatdoseGrid = thisDose,
            CITDEOT = thisCITDEOT,
            ratioTDEOT = thisratioTDEOT,
            fit = thisFit,
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results
          )
        return(thisResult)
      }


      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truth",
            "object"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")


      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialatdoseGrid"))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))


      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialatdoseGrid"))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final TDEOT 95% CI obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final TDEOT ratios obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))
      ## set up the list for the final fits

      fitList <- lapply(resultList, "[[", "fit")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))


      ## return the results in the Simulations class object
      ret <- PseudoSimulations(
        data = dataList,
        doses = recommendedDoses,
        fit = fitList,
        final_td_target_during_trial_estimates = TDtargetDuringTrialList,
        final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
        final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
        final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
        final_cis = CIList,
        final_ratios = ratioList,
        final_tdeot_cis = CITDEOTList,
        final_tdeot_ratios = ratioTDEOTList,
        stop_reasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )

      return(ret)
    }
)
## -----------------------------------------------------------------------------------------------
## Simulate design using DLE and efficacy responses without DLE and efficacy samples (pseudo models)
## --------------------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure using both DLE and efficacy responses.
##' This is a method based on the \code{\linkS4class{DualResponsesDesign}} where DLEmodel used are of
##' \code{\linkS4class{ModelTox}} class object and efficacy model used are of \code{\linkS4class{ModelEff}}
##' class object. In addition, no DLE and efficacy samples are involved or generated in the simulation
##' process
##'
##' @param object the \code{\linkS4class{DualResponsesDesign}} object we want to simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected efficacy
##' responses (vector). Additional arguments can be supplied in \code{args}.
##' @param trueNu the precision, the inverse of the variance of the efficacy responses
##' @param args data frame with arguments for the \code{trueDLE} and
##' \code{trueEff} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##' @param \dots not used
##'
##' @example examples/design-method-simulateDualResponsesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoDualSimulations}}
##'
##' @export
##' @keywords methods

setMethod("simulate",
  signature =
    signature(
      object = "DualResponsesDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             trueDLE, trueEff, trueNu,
             args = NULL, firstSeparate = FALSE,
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## checks and extracts
      assert_function(trueDLE)
      assert_function(trueEff)
      assert_true(trueNu > 0)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## get names of arguments (excluding the first one which is the dose)
      trueDLEArgnames <- names(formals(trueDLE))[-1]
      trueEffArgnames <- names(formals(trueEff))[-1]



      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth DLE function is...
        thisTruthDLE <- function(dose) {
          do.call(
            trueDLE,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the DLE function
              as.list(thisArgs)[trueDLEArgnames]
            )
          )
        }

        ## and the truth Eff function is:
        thisTruthEff <- function(dose) {
          do.call(
            trueEff,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments: take only those that
              ## are required by the Eff function
              as.list(thisArgs)[trueEffArgnames]
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        ## find true sigma2 to generate responses

        trueSigma2 <- 1 / trueNu

        ## start the simulated data with the provided one
        thisData <- object@data

        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruthDLE(object@data@doseGrid[1])

          ## what is the mean efficacy at placebo?
          thisMeanEff.PL <- thisTruthEff(object@data@doseGrid[1])
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisDLEProb <- thisTruthDLE(thisDose)
          thisMeanEff <- thisTruthEff(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )


          ## In case there are placebo
          ## what is the cohort size at this dose for Placebo?
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }


          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisDLEProb
            )


            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            thisEff <- rnorm(
              n = 1L,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisEff.PL <- rnorm(
                n = 1L,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }

            ## if there is no DLT:
            if (thisDLTs == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisDLEProb
                )
              )

              thisEff <- c(
                thisEff,
                rnorm(
                  n = thisSize - 1L,
                  mean = thisMeanEff,
                  sd = sqrt(trueSigma2)
                )
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
                thisEff.PL <- c(
                  thisMeanEff.PL,
                  rnorm(
                    n = thisSize.PL,
                    mean = thisMeanEff.PL,
                    sd = sqrt(trueSigma2)
                  )
                )
              }
            }
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisDLEProb
            )
            thisEff <- rnorm(
              n = thisSize,
              mean = thisMeanEff,
              sd = sqrt(trueSigma2)
            )

            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
              thisEff.PL <- rnorm(
                n = thisSize.PL,
                mean = thisMeanEff.PL,
                sd = sqrt(trueSigma2)
              )
            }
          }

          ## update the data with this placebo (if any) cohort and then with active dose
          if (thisData@placebo && (thisSize.PL > 0L)) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL,
              w = thisEff.PL,
              check = FALSE
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff,
              new_cohort = FALSE
            )
          } else {
            ## update the data with this cohort
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              w = thisEff
            )
          }
          ## Update model estimate in DLE and Eff models
          thisDLEModel <- update(
            object = object@model,
            data = thisData
          )

          thisEffModel <- update(
            object = object@eff_model,
            data = thisData
          )

          thisNu <- thisEffModel@nu


          thisSigma2 <- if (thisEffModel@use_fixed) {
            1 / thisNu
          } else {
            1 / (as.numeric(thisNu["a"] / thisNu["b"]))
          }


          ## what is the dose limit?
          doselimit <- maxDose(object@increments, data = thisData)



          ## => what is the next best dose?
          next_bd <- nextBest(object@nextBest,
            doselimit = doselimit,
            model = thisDLEModel,
            data = thisData,
            model_eff = thisEffModel,
            in_sim = TRUE
          )

          thisDose <- next_bd$next_dose
          thisTDtargetDuringTrial <- next_bd$dose_target_drt
          thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
          thisTDtargetEndOfTrial <- next_bd$dose_target_eot
          thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
          thisGstar <- next_bd$dose_max_gain
          thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

          Recommend <- min(thisTDtargetEndOfTrialAtDoseGrid, thisGstarAtDoseGrid)

          ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
          thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
          thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

          thisCIGstar <- list(lower = next_bd$ci_dose_max_gain[1], upper = next_bd$ci_dose_max_gain[2])
          thisratioGstar <- next_bd$ci_ratio_dose_max_gain

          ## Find the optimal dose
          OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

          if (OptimalDose == thisGstar) {
            thisratio <- thisratioGstar
            thisCI <- thisCIGstar
          } else {
            thisratio <- thisratioTDEOT
            thisCI <- thisCITDEOT
          }

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            model = thisDLEModel,
            data = thisData,
            Effmodel = thisEffModel
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fits
        prob_fun <- probFunction(thisDLEModel, phi1 = thisDLEModel@phi1, phi2 = thisDLEModel@phi2)
        thisDLEFit <- list(
          phi1 = thisDLEModel@phi1,
          phi2 = thisDLEModel@phi2,
          probDLE = prob_fun(object@data@doseGrid)
        )

        eff_fun <- efficacyFunction(thisEffModel, theta1 = thisEffModel@theta1, theta2 = thisEffModel@theta2)
        thisEffFit <- list(
          theta1 = thisEffModel@theta1,
          theta2 = thisEffModel@theta2,
          ExpEff = eff_fun(object@data@doseGrid)
        )


        ## return the results
        thisResult <- list(
          data = thisData,
          dose = thisDose,
          TDtargetDuringTrial = thisTDtargetDuringTrial,
          TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
          TDtargetEndOfTrial = thisTDtargetEndOfTrial,
          TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
          Gstar = thisGstar,
          GstarAtDoseGrid = thisGstarAtDoseGrid,
          Recommend = Recommend,
          OptimalDose = OptimalDose,
          OptimalDoseAtDoseGrid = Recommend,
          ratio = thisratio,
          CI = thisCI,
          ratioGstar = thisratioGstar,
          CIGstar = thisCIGstar,
          ratioTDEOT = thisratioTDEOT,
          CITDEOT = thisCITDEOT,
          fitDLE = thisDLEFit,
          fitEff = thisEffFit,
          sigma2est = thisSigma2,
          stop = attr(
            stopit,
            "message"
          ),
          report_results = stopit_results
        )

        return(thisResult)
      }


      resultList <- get_result_list(
        fun = runSim,
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "trueDLE",
            "trueEff",
            "trueNu",
            "object"
          ),
        parallel = parallel,
        n_cores = nCores
      )


      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")

      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))


      ## set up list for the final TD during Trial Estimate
      TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

      ## set up list for the final TD End of Trial Estimate
      TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

      ## set up list for the final TD during Trial estimate at dose Grid
      TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialAtDoseGrid"))

      ## set up list for the final TD End Of Trial estimate at dose Grid
      TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialAtDoseGrid"))

      ## set up list for the final Gstar estimates
      GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

      ## set up list for the final Gstar estimates at dose grid
      GstarAtDoseGridList <- as.numeric(sapply(resultList, "[[", "GstarAtDoseGrid"))

      ## set up list for final optimal dose estimates
      OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

      ## set up list for final optimal dose estimates at dose Grid
      OptimalDoseAtDoseGridList <- as.numeric(sapply(resultList, "[[", "Recommend"))

      ## Set up the list for the final 95% CI obtained
      CIList <- lapply(resultList, "[[", "CI")

      ## Set up the list for the final ratios obtained
      ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

      ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
      CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

      ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
      ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

      ## Set up the list for the final 95% CI of the Gstar obtained
      CIGstarList <- lapply(resultList, "[[", "CIGstar")

      ## Set up the list for the final ratios of the Gstar obtained
      ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))



      ## set up the list for the final fits
      fitDLEList <- lapply(resultList, "[[", "fitDLE")
      fitEffList <- lapply(resultList, "[[", "fitEff")


      ## the vector of the sigma2
      sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))


      ## return the results in the Simulations class object
      ret <- PseudoDualSimulations(
        data = dataList,
        doses = recommendedDoses,
        final_td_target_during_trial_estimates = TDtargetDuringTrialList,
        final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
        final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
        final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
        final_cis = CIList,
        final_ratios = ratioList,
        FinalGstarEstimates = GstarList,
        FinalGstarAtDoseGrid = GstarAtDoseGridList,
        FinalGstarCIs = CIGstarList,
        FinalGstarRatios = ratioGstarList,
        final_tdeot_cis = CITDEOTList,
        final_tdeot_ratios = ratioTDEOTList,
        FinalOptimalDose = OptimalDoseList,
        FinalOptimalDoseAtDoseGrid = OptimalDoseAtDoseGridList,
        fit = fitDLEList,
        fitEff = fitEffList,
        sigma2est = sigma2Estimates,
        stop_reasons = stopReasons,
        stop_report = stop_report,
        seed = RNGstate
      )
      return(ret)
    }
)

## =========================================================================
## -----------------------------------------------------------------------------------------------
## Simulate design using DLE and efficacy responses with DLE and efficacy samples (pseudo models)
## --------------------------------------------------------------------------------------------
###
##' This is a methods to simulate dose escalation procedure using both DLE and efficacy responses.
##' This is a method based on the \code{\linkS4class{DualResponsesSamplesDesign}} where DLEmodel
##' used are of
##' \code{\linkS4class{ModelTox}} class object and efficacy model used are of
##' \code{\linkS4class{ModelEff}}
##' class object (special case is \code{\linkS4class{EffFlexi}} class model object).
##' In addition, DLE and efficacy samples are involved or generated in the simulation
##' process
##'
##' @param object the \code{\linkS4class{DualResponsesSamplesDesign}} object we want to
##' simulate the data from
##' @param nsim the number of simulations (default :1)
##' @param seed see \code{\link{set_seed}}
##' @param trueDLE a function which takes as input a dose (vector) and returns the true probability
##' (vector) of the occurrence of a DLE. Additional arguments can be supplied in \code{args}.
##' @param trueEff a function which takes as input a dose (vector) and returns the expected
##' efficacy responses (vector). Additional arguments can be supplied in \code{args}.
##' @param trueNu (not with code{\linkS4class{EffFlexi}}) the precision, the inverse of the
##' variance of the efficacy responses
##' @param trueSigma2 (only with code{\linkS4class{EffFlexi}}) the true variance of the efficacy
##' responses which must be a single positive scalar.
##' @param trueSigma2betaW (only with code{\linkS4class{EffFlexi}}) the true variance for the
##' random walk model used for smoothing. This must be a single positive scalar.
##' @param args data frame with arguments for the \code{trueDLE} and
##' \code{trueEff} function. The column names correspond to the argument
##' names, the rows to the values of the arguments. The rows are appropriately
##' recycled in the \code{nsim} simulations.
##' @param firstSeparate enroll the first patient separately from the rest of
##' the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##' in this patient.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##' giving the MCMC options for each evaluation in the trial. By default,
##' the standard options are used
##' @param parallel should the simulation runs be parallelized across the
##' clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine, maximum 5.
##'
##' @param ... not used.
##'
##' @example examples/design-method-simulateDualResponsesSamplesDesign.R
##'
##' @return an object of class \code{\linkS4class{PseudoDualSimulations}} or
##' \code{\linkS4class{PseudoDualFlexiSimulations}}
##'
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "DualResponsesSamplesDesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             trueDLE, trueEff, trueNu = NULL,
             trueSigma2 = NULL, trueSigma2betaW = NULL,
             args = NULL, firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE, nCores =
               min(parallel::detectCores(), 5L),
             ...) {
      ## common checks and extracts
      assert_function(trueDLE)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      ## check if special case applies
      isFlexi <- is(object@eff_model, "EffFlexi")

      ## conditional code from here on:
      if (isFlexi) {
        ## special checks and extracts
        stopifnot(
          trueSigma2 > 0,
          trueSigma2betaW > 0,
          is.numeric(trueEff),
          length(trueEff) == length(object@data@doseGrid)
        )

        args <- as.data.frame(args)
        nArgs <- max(nrow(args), 1L)

        ## get names of arguments (excluding the first one which is the dose)
        trueDLEArgnames <- names(formals(trueDLE))[-1]

        ## seed handling
        RNGstate <- set_seed(seed)

        ## from this,
        ## generate the individual seeds for the simulation runs
        simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

        ## the function to produce the run a single simulation
        ## with index "iterSim"
        runSim <- function(iterSim) {
          ## set the seed for this run
          set.seed(simSeeds[iterSim])

          ## what is now the argument for the truth?
          ## (appropriately recycled)
          thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

          ## so this truth is...
          thisTruthDLE <- function(dose) {
            do.call(
              trueDLE,
              ## First argument: the dose
              c(
                dose,
                ## Following arguments
                thisArgs
              )
            )
          }

          ## get the true Eff
          thisTruthEff <- trueEff

          ## start the simulated data with the provided one
          thisData <- object@data

          ## shall we stop the trial?
          ## First, we want to continue with the starting dose.
          ## This variable is updated after each cohort in the loop.
          stopit <- FALSE

          ## what is the next dose to be used?
          ## initialize with starting dose
          thisDose <- object@startingDose

          ## Start with specified sigma2 and sigma2betaW
          thisSigma2 <- trueSigma2
          thisSigma2betaW <- trueSigma2betaW


          ## inside this loop we simulate the whole trial, until stopping
          while (!stopit) {
            ## what is the probability for tox. at this dose?
            thisDLEProb <- thisTruthDLE(thisDose)
            thisDoseIndex <- which(thisDose == thisData@doseGrid)
            thisMeanEff <- thisTruthEff[thisDoseIndex]



            ## what is the cohort size at this dose?
            thisSize <- size(object@cohort_size,
              dose = thisDose,
              data = thisData
            )

            if (thisData@placebo) {
              thisSize.PL <- size(object@pl_cohort_size,
                dose = thisDose,
                data = thisData
              )
            }

            ## simulate DLTs: depends on whether we
            ## separate the first patient or not.
            if (firstSeparate && (thisSize > 1L)) {
              ## dose the first patient
              thisDLTs <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisDLEProb
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = 1L,
                  size = 1L,
                  prob = thisProb.PL
                )
              }

              thisEff <- rnorm(
                n = 1L,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisEff.PL <- rnorm(
                  n = 1L,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }

              ## if there is no DLT:
              if (thisDLTs == 0) {
                ## enroll the remaining patients
                thisDLTs <- c(
                  thisDLTs,
                  rbinom(
                    n = thisSize - 1L,
                    size = 1L,
                    prob = thisDLEProb
                  )
                )
                thisEff <- c(
                  thisEff,
                  rnorm(
                    n = thisSize - 1L,
                    mean = thisMeanEff,
                    sd = sqrt(trueSigma2)
                  )
                )
                if (thisData@placebo && (thisSize.PL > 0L)) {
                  thisDLTs.PL <- c(
                    thisDLTs.PL,
                    rbinom(
                      n = thisSize.PL,
                      size = 1L,
                      prob = thisProb.PL
                    )
                  )
                  thisEff.PL <- c(
                    thisMeanEff.PL,
                    rnorm(
                      n = thisSize.PL,
                      mean = thisMeanEff.PL,
                      sd = sqrt(trueSigma2)
                    )
                  )
                }
              }
            } else {
              ## we can directly dose all patients
              thisDLTs <- rbinom(
                n = thisSize,
                size = 1L,
                prob = thisDLEProb
              )

              thisEff <- rnorm(
                n = thisSize,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )
              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = thisSize.PL,
                  size = 1L,
                  prob = thisProb.PL
                )
                thisEff.PL <- rnorm(
                  n = thisSize.PL,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }
            }

            ## update the data with this placebo (if any) cohort and then with active dose
            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisData <- update(
                object = thisData,
                x = object@data@doseGrid[1],
                y = thisDLTs.PL,
                w = thisEff.PL,
                check = FALSE
              )

              ## update the data with active dose
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff,
                new_cohort = FALSE
              )
            } else {
              ## update the data with this cohort
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff
              )
            }

            ## Update model estimate in DLE model
            thisDLEModel <- update(
              object = object@model,
              data = thisData
            )

            thisEffModel <- update(
              object = object@eff_model,
              data = thisData
            )


            ## what is the dose limit?
            doselimit <- maxDose(object@increments,
              data = thisData
            )

            ## generate DLE and Eff samples from the DLE and Eff model
            thisDLEsamples <- mcmc(
              data = thisData,
              model = thisDLEModel,
              options = mcmcOptions
            )

            thisEffsamples <- mcmc(
              data = thisData,
              model = thisEffModel,
              options = mcmcOptions
            )

            thisSigma2 <- mean(thisEffsamples@data$sigma2W)

            thisSigma2betaW <- mean(thisEffsamples@data$sigma2betaW)

            ## => what is the next best dose?

            next_bd <- nextBest(object@nextBest,
              doselimit = doselimit,
              samples = thisDLEsamples,
              model = thisDLEModel,
              model_eff = thisEffModel,
              samples_eff = thisEffsamples,
              data = thisData,
              in_sim = TRUE
            )

            thisDose <- next_bd$next_dose
            thisTDtargetDuringTrial <- next_bd$dose_target_drt
            thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
            thisTDtargetEndOfTrial <- next_bd$dose_target_eot
            thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
            thisGstar <- next_bd$dose_max_gain
            thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

            Recommend <- min(thisTDtargetEndOfTrialAtDoseGrid, thisGstarAtDoseGrid)

            ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
            thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
            thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

            thisCIGstar <- list(lower = next_bd$ci_dose_max_gain[1], upper = next_bd$ci_dose_max_gain[2])
            thisratioGstar <- next_bd$ci_ratio_dose_max_gain

            ## Find the optimal dose
            OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

            if (OptimalDose == thisGstar) {
              thisratio <- thisratioGstar
              thisCI <- thisCIGstar
            } else {
              thisratio <- thisratioTDEOT
              thisCI <- thisCITDEOT
            }

            ## evaluate stopping rules
            stopit <- stopTrial(object@stopping,
              dose = thisDose,
              samples = thisDLEsamples,
              model = thisDLEModel,
              data = thisData,
              TDderive = object@nextBest@derive,
              Effmodel = thisEffModel,
              Effsamples = thisEffsamples,
              Gstarderive = object@nextBest@mg_derive
            )
            stopit_results <- h_unpack_stopit(stopit)
          }

          ## get the fits

          thisDLEFit <- fit(
            object = thisDLEsamples,
            model = thisDLEModel,
            data = thisData
          )

          thisEffFit <- fit(
            object = thisEffsamples,
            model = thisEffModel,
            data = thisData
          )


          ## return the results
          thisResult <-
            list(
              data = thisData,
              dose = thisDose,
              TDtargetDuringTrial = thisTDtargetDuringTrial,
              TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
              TDtargetEndOfTrial = thisTDtargetEndOfTrial,
              TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
              Gstar = thisGstar,
              GstarAtDoseGrid = thisGstarAtDoseGrid,
              Recommend = Recommend,
              OptimalDose = OptimalDose,
              OptimalDoseAtDoseGrid = Recommend,
              ratio = thisratio,
              CI = thisCI,
              ratioGstar = thisratioGstar,
              CIGstar = thisCIGstar,
              ratioTDEOT = thisratioTDEOT,
              CITDEOT = thisCITDEOT,
              fitDLE = subset(thisDLEFit,
                select =
                  c(middle, lower, upper)
              ),
              fitEff = subset(thisEffFit,
                select =
                  c(middle, lower, upper)
              ),
              sigma2est = thisSigma2,
              sigma2betaWest = thisSigma2betaW,
              stop =
                attr(
                  stopit,
                  "message"
                ),
              report_results = stopit_results
            )

          return(thisResult)
        }

        resultList <- get_result_list(
          fun = runSim,
          nsim = nsim,
          vars =
            c(
              "simSeeds",
              "args",
              "nArgs",
              "firstSeparate",
              "trueDLE",
              "trueEff",
              "trueSigma2",
              "trueSigma2betaW",
              "object",
              "mcmcOptions"
            ),
          parallel = parallel,
          n_cores = nCores
        )

        ## put everything in the Simulations format:

        ## setup the list for the simulated data objects
        dataList <- lapply(resultList, "[[", "data")

        ## the vector of the final dose recommendations
        recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))


        ## set up the list for the final fits for both DLE and efficacy
        fitDLEList <- lapply(resultList, "[[", "fitDLE")
        fitEffList <- lapply(resultList, "[[", "fitEff")

        ## the vector of sigma2 estimates
        sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

        ## the vector of sigma2betaW estimates
        sigma2betaWEstimates <- as.numeric(sapply(resultList, "[[", "sigma2betaWest"))

        ## set up list for the final TD during Trial Estimate
        TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

        ## set up list for the final TD End of Trial Estimate
        TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

        ## set up list for the final TD during Trial estimate at dose Grid
        TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialAtDoseGrid"))

        ## set up list for the final TD End Of Trial estimate at dose Grid
        TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialAtDoseGrid"))

        ## set up list for the final Gstar estimates
        GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

        ## set up list for the final Gstar estimates at dose grid
        GstarAtDoseGridList <- as.numeric(sapply(resultList, "[[", "GstarAtDoseGrid"))

        ## set up list for final optimal dose estimates
        OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

        ## set up list for final optimal dose estimates at dose Grid
        OptimalDoseAtDoseGridList <- as.numeric(sapply(resultList, "[[", "Recommend"))

        ## Set up the list for the final 95% CI obtained
        CIList <- lapply(resultList, "[[", "CI")

        ## Set up the list for the final ratios obtained
        ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

        ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
        CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

        ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
        ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

        ## Set up the list for the final 95% CI of the Gstar obtained
        CIGstarList <- lapply(resultList, "[[", "CIGstar")

        ## Set up the list for the final ratios of the Gstar obtained
        ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))

        ## the reasons for stopping
        stopReasons <- lapply(resultList, "[[", "stop")

        # individual stopping rule results as matrix, labels as column names
        stop_results <- lapply(resultList, "[[", "report_results")
        stop_report <- as.matrix(do.call(rbind, stop_results))


        ## return the results in the Simulations class object
        ret <- PseudoDualFlexiSimulations(
          data = dataList,
          doses = recommendedDoses,
          final_td_target_during_trial_estimates = TDtargetDuringTrialList,
          final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
          final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
          final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
          final_cis = CIList,
          final_ratios = ratioList,
          FinalGstarEstimates = GstarList,
          FinalGstarAtDoseGrid = GstarAtDoseGridList,
          FinalGstarCIs = CIGstarList,
          FinalGstarRatios = ratioGstarList,
          final_tdeot_cis = CITDEOTList,
          final_tdeot_ratios = ratioTDEOTList,
          FinalOptimalDose = OptimalDoseList,
          FinalOptimalDoseAtDoseGrid = OptimalDoseAtDoseGridList,
          fit = fitDLEList,
          fitEff = fitEffList,
          sigma2est = sigma2Estimates,
          sigma2betaWest = sigma2betaWEstimates,
          stop_reasons = stopReasons,
          stop_report = stop_report,
          seed = RNGstate
        )

        return(ret)
      } else {
        stopifnot(
          trueNu > 0,
          is.function(trueEff)
        )


        args <- as.data.frame(args)
        nArgs <- max(nrow(args), 1L)

        ## get names of arguments (excluding the first one which is the dose)
        trueDLEArgnames <- names(formals(trueDLE))[-1]
        trueEffArgnames <- names(formals(trueEff))[-1]



        ## seed handling
        RNGstate <- set_seed(seed)

        ## from this,
        ## generate the individual seeds for the simulation runs
        simSeeds <- sample(x = seq_len(1e5), size = nsim)

        ## the function to produce the run a single simulation
        ## with index "iterSim"
        runSim <- function(iterSim) {
          ## set the seed for this run
          set.seed(simSeeds[iterSim])

          ## what is now the argument for the truth?
          ## (appropriately recycled)
          thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

          ## so this truth DLE function is...
          thisTruthDLE <- function(dose) {
            do.call(
              trueDLE,
              ## First argument: the dose
              c(
                dose,
                ## Following arguments: take only those that
                ## are required by the DLE function
                as.list(thisArgs)[trueDLEArgnames]
              )
            )
          }

          ## and the truth Eff function is:
          thisTruthEff <- function(dose) {
            do.call(
              trueEff,
              ## First argument: the dose
              c(
                dose,
                ## Following arguments: take only those that
                ## are required by the Eff function
                as.list(thisArgs)[trueEffArgnames]
              )
            )
          }

          ## find true sigma2 to generate responses

          trueSigma2 <- 1 / trueNu

          ## start the simulated data with the provided one
          thisData <- object@data


          ## shall we stop the trial?
          ## First, we want to continue with the starting dose.
          ## This variable is updated after each cohort in the loop.
          stopit <- FALSE

          ## what is the next dose to be used?
          ## initialize with starting dose
          thisDose <- object@startingDose

          ## inside this loop we simulate the whole trial, until stopping
          while (!stopit) {
            ## what is the probability for tox. at this dose?
            thisDLEProb <- thisTruthDLE(thisDose)
            thisMeanEff <- thisTruthEff(thisDose)

            ## what is the cohort size at this dose?
            thisSize <- size(object@cohort_size,
              dose = thisDose,
              data = thisData
            )

            ## simulate DLTs: depends on whether we
            ## separate the first patient or not.
            if (firstSeparate && (thisSize > 1L)) {
              ## dose the first patient
              thisDLTs <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisDLEProb
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = 1L,
                  size = 1L,
                  prob = thisProb.PL
                )
              }

              thisEff <- rnorm(
                n = 1L,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisEff.PL <- rnorm(
                  n = 1L,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }

              ## if there is no DLT:
              if (thisDLTs == 0) {
                ## enroll the remaining patients
                thisDLTs <- c(
                  thisDLTs,
                  rbinom(
                    n = thisSize - 1L,
                    size = 1L,
                    prob = thisDLEProb
                  )
                )
                thisEff <- c(
                  thisEff,
                  rnorm(
                    n = thisSize - 1L,
                    mean = thisMeanEff,
                    sd = sqrt(trueSigma2)
                  )
                )


                if (thisData@placebo && (thisSize.PL > 0L)) {
                  thisDLTs.PL <- c(
                    thisDLTs.PL,
                    rbinom(
                      n = thisSize.PL,
                      size = 1L,
                      prob = thisProb.PL
                    )
                  )
                  thisEff.PL <- c(
                    thisMeanEff.PL,
                    rnorm(
                      n = thisSize.PL,
                      mean = thisMeanEff.PL,
                      sd = sqrt(trueSigma2)
                    )
                  )
                }
              }
            } else {
              ## we can directly dose all patients
              thisDLTs <- rbinom(
                n = thisSize,
                size = 1L,
                prob = thisDLEProb
              )
              thisEff <- rnorm(
                n = thisSize,
                mean = thisMeanEff,
                sd = sqrt(trueSigma2)
              )

              if (thisData@placebo && (thisSize.PL > 0L)) {
                thisDLTs.PL <- rbinom(
                  n = thisSize.PL,
                  size = 1L,
                  prob = thisProb.PL
                )
                thisEff.PL <- rnorm(
                  n = thisSize.PL,
                  mean = thisMeanEff.PL,
                  sd = sqrt(trueSigma2)
                )
              }
            }



            ## update the data with this placebo (if any) cohort and then with active dose
            if (thisData@placebo && (thisSize.PL > 0L)) {
              thisData <- update(
                object = thisData,
                x = object@data@doseGrid[1],
                y = thisDLTs.PL,
                w = thisEff.PL,
                check = FALSE
              )

              ## update the data with active dose
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff,
                new_cohort = FALSE
              )
            } else {
              ## update the data with this cohort
              thisData <- update(
                object = thisData,
                x = thisDose,
                y = thisDLTs,
                w = thisEff
              )
            }


            ## Update model estimate in DLE and Eff models
            thisDLEModel <- update(
              object = object@model,
              data = thisData
            )

            thisEffModel <- update(
              object = object@eff_model,
              data = thisData
            )

            thisNu <- thisEffModel@nu

            thisDLEsamples <- mcmc(
              data = thisData,
              model = thisDLEModel,
              options = mcmcOptions
            )

            thisEffsamples <- mcmc(
              data = thisData,
              model = thisEffModel,
              options = mcmcOptions
            )

            thisSigma2 <- if (thisEffModel@use_fixed) {
              1 / thisNu
            } else {
              1 / (as.numeric(thisNu["a"] / thisNu["b"]))
            }

            ## what is the dose limit?
            doselimit <- maxDose(object@increments, data = thisData)



            ## => what is the next best dose?
            next_bd <- nextBest(object@nextBest,
              doselimit = doselimit,
              samples = thisDLEsamples,
              model = thisDLEModel,
              data = thisData,
              model_eff = thisEffModel,
              samples_eff = thisEffsamples,
              in_sim = TRUE
            )

            thisDose <- next_bd$next_dose
            thisTDtargetDuringTrial <- next_bd$dose_target_drt
            thisTDtargetDuringTrialAtDoseGrid <- next_bd$next_dose_drt
            thisTDtargetEndOfTrial <- next_bd$dose_target_eot
            thisTDtargetEndOfTrialAtDoseGrid <- next_bd$next_dose_eot
            thisGstar <- next_bd$dose_max_gain
            thisGstarAtDoseGrid <- next_bd$next_dose_max_gain

            Recommend <- min(thisTDtargetEndOfTrialAtDoseGrid, thisGstarAtDoseGrid)

            ## Find the 95 % CI and its ratio (upper to the lower of this 95% CI of each of the estimates)
            thisCITDEOT <- list(lower = next_bd$ci_dose_target_eot[1], upper = next_bd$ci_dose_target_eot[2])
            thisratioTDEOT <- next_bd$ci_ratio_dose_target_eot

            thisCIGstar <- list(lower = next_bd$ci_dose_max_gain[1], upper = next_bd$ci_dose_max_gain[2])
            thisratioGstar <- next_bd$ci_ratio_dose_max_gain

            ## Find the optimal dose
            OptimalDose <- min(thisGstar, thisTDtargetEndOfTrial)

            if (OptimalDose == thisGstar) {
              thisratio <- thisratioGstar
              thisCI <- thisCIGstar
            } else {
              thisratio <- thisratioTDEOT
              thisCI <- thisCITDEOT
            }


            ## evaluate stopping rules
            stopit <- stopTrial(object@stopping,
              dose = thisDose,
              samples = thisDLEsamples,
              model = thisDLEModel,
              data = thisData,
              TDderive = object@nextBest@derive,
              Effmodel = thisEffModel,
              Effsamples = thisEffsamples,
              Gstarderive = object@nextBest@mg_derive
            )
            stopit_results <- h_unpack_stopit(stopit)
          }
          ## get the fit
          thisDLEFit <- fit(
            object = thisDLEsamples,
            model = thisDLEModel,
            data = thisData
          )

          thisEffFit <- fit(
            object = thisEffsamples,
            model = thisEffModel,
            data = thisData
          )


          ## return the results
          thisResult <- list(
            data = thisData,
            dose = thisDose,
            TDtargetDuringTrial = thisTDtargetDuringTrial,
            TDtargetDuringTrialAtDoseGrid = thisTDtargetDuringTrialAtDoseGrid,
            TDtargetEndOfTrial = thisTDtargetEndOfTrial,
            TDtargetEndOfTrialAtDoseGrid = thisTDtargetEndOfTrialAtDoseGrid,
            Gstar = thisGstar,
            GstarAtDoseGrid = thisGstarAtDoseGrid,
            Recommend = Recommend,
            OptimalDose = OptimalDose,
            OptimalDoseAtDoseGrid = Recommend,
            ratio = thisratio,
            CI = thisCI,
            ratioGstar = thisratioGstar,
            CIGstar = thisCIGstar,
            ratioTDEOT = thisratioTDEOT,
            CITDEOT = thisCITDEOT,
            fitDLE = subset(thisDLEFit,
              select =
                c(middle, lower, upper)
            ),
            fitEff = subset(thisEffFit,
              select =
                c(middle, lower, upper)
            ),
            sigma2est = thisSigma2,
            stop = attr(
              stopit,
              "message"
            ),
            report_results = stopit_results
          )

          return(thisResult)
        }


        resultList <- get_result_list(
          fun = runSim,
          nsim = nsim,
          vars =
            c(
              "simSeeds",
              "args",
              "nArgs",
              "firstSeparate",
              "trueDLE",
              "trueEff",
              "trueNu",
              "object"
            ),
          parallel = parallel,
          n_cores = nCores
        )


        ## put everything in the Simulations format:

        ## setup the list for the simulated data objects
        dataList <- lapply(resultList, "[[", "data")

        ## the vector of the final dose recommendations
        recommendedDoses <- as.numeric(sapply(resultList, "[[", "Recommend"))

        ## set up list for the final TD during Trial Estimate
        TDtargetDuringTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrial"))

        ## set up list for the final TD End of Trial Estimate
        TDtargetEndOfTrialList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrial"))

        ## set up list for the final TD during Trial estimate at dose Grid
        TDtargetDuringTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetDuringTrialAtDoseGrid"))

        ## set up list for the final TD End Of Trial estimate at dose Grid
        TDtargetEndOfTrialDoseGridList <- as.numeric(sapply(resultList, "[[", "TDtargetEndOfTrialAtDoseGrid"))

        ## set up list for the final Gstar estimates
        GstarList <- as.numeric(sapply(resultList, "[[", "Gstar"))

        ## set up list for the final Gstar estimates at dose grid
        GstarAtDoseGridList <- as.numeric(sapply(resultList, "[[", "GstarAtDoseGrid"))

        ## set up list for final optimal dose estimates
        OptimalDoseList <- as.numeric(sapply(resultList, "[[", "OptimalDose"))

        ## set up list for final optimal dose estimates at dose Grid
        OptimalDoseAtDoseGridList <- as.numeric(sapply(resultList, "[[", "Recommend"))

        ## Set up the list for the final 95% CI obtained
        CIList <- lapply(resultList, "[[", "CI")

        ## Set up the list for the final ratios obtained
        ratioList <- as.numeric(sapply(resultList, "[[", "ratio"))

        ## Set up the list for the final 95% CI of the TDtarget End Of Trial obtained
        CITDEOTList <- lapply(resultList, "[[", "CITDEOT")

        ## Set up the list for the final ratios of the TDtarget End Of Trial obtained
        ratioTDEOTList <- as.numeric(sapply(resultList, "[[", "ratioTDEOT"))

        ## Set up the list for the final 95% CI of the Gstar obtained
        CIGstarList <- lapply(resultList, "[[", "CIGstar")

        ## Set up the list for the final ratios of the Gstar obtained
        ratioGstarList <- as.numeric(sapply(resultList, "[[", "ratioGstar"))

        ## set up the list for the final fits for both DLE and efficacy
        fitDLEList <- lapply(resultList, "[[", "fitDLE")
        fitEffList <- lapply(resultList, "[[", "fitEff")
        ## the vector of the sigma2
        sigma2Estimates <- as.numeric(sapply(resultList, "[[", "sigma2est"))

        ## the reasons for stopping
        stopReasons <- lapply(resultList, "[[", "stop")

        # individual stopping rule results as matrix, labels as column names
        stop_results <- lapply(resultList, "[[", "report_results")
        stop_report <- as.matrix(do.call(rbind, stop_results))


        ## return the results in the Simulations class object
        ret <- PseudoDualSimulations(
          data = dataList,
          doses = recommendedDoses,
          final_td_target_during_trial_estimates = TDtargetDuringTrialList,
          final_td_target_end_of_trial_estimates = TDtargetEndOfTrialList,
          final_td_target_during_trial_at_dose_grid = TDtargetDuringTrialDoseGridList,
          final_td_target_end_of_trial_at_dose_grid = TDtargetEndOfTrialDoseGridList,
          final_cis = CIList,
          final_ratios = ratioList,
          FinalGstarEstimates = GstarList,
          FinalGstarAtDoseGrid = GstarAtDoseGridList,
          FinalGstarCIs = CIGstarList,
          FinalGstarRatios = ratioGstarList,
          final_tdeot_cis = CITDEOTList,
          final_tdeot_ratios = ratioTDEOTList,
          FinalOptimalDose = OptimalDoseList,
          FinalOptimalDoseAtDoseGrid = OptimalDoseAtDoseGridList,
          fit = fitDLEList,
          fitEff = fitEffList,
          sigma2est = sigma2Estimates,
          stop_reasons = stopReasons,
          stop_report = stop_report,
          seed = RNGstate
        )
        return(ret)
      }
    }
)

## --------------------------------------------------------------------------

##' Simulate outcomes from a time-to-DLT augmented CRM design (`DADesign`)
##'
##' @param object the \code{\linkS4class{DADesign}} object we want to simulate
##'   data from
##' @param nsim the number of simulations (default: 1)
##' @param seed see \code{\link{set_seed}}
##' @param truthTox a function which takes as input a dose (vector) and returns the
##'   true probability (vector) for toxicity and the time DLT occurs. Additional
##'   arguments can be supplied in \code{args}.
##' @param truthSurv a CDF which takes as input a time (vector) and returns
##'   the true cumulative probability (vector) that the DLT would occur conditioning on the patient
##'   has DLTs.
##' @param trueTmax (`number` or `NULL`)\cr the true maximum time at which DLTs can occur. Note that this must be larger thank `Tmax` from the `object`'s base data, which is the length of the DLT window, i.e. until which time DLTs are officially declared as such and used in the trial.
##' @param args data frame with arguments for the \code{truth} function. The
##'   column names correspond to the argument names, the rows to the values of the
##'   arguments. The rows are appropriately recycled in the \code{nsim}
##'   simulations. In order to produce outcomes from the posterior predictive
##'   distribution, e.g, pass an \code{object} that contains the data observed so
##'   far, \code{truth} contains the \code{prob} function from the model in
##'   \code{object}, and \code{args} contains posterior samples from the model.
##' @param firstSeparate enroll the first patient separately from the rest of
##'   the cohort? (not default) If yes, the cohort will be closed if a DLT occurs
##'   in this patient.
##' @param deescalate deescalation when a DLT occurs in cohorts with lower dose
##'   level.
##' @param mcmcOptions object of class \code{\linkS4class{McmcOptions}},
##'   giving the MCMC options for each evaluation in the trial. By default,
##'   the standard options are used.
##' @param DA document or rename this parameter to make it more meaningful
##' @param parallel should the simulation runs be parallelized across the
##'   clusters of the computer? (not default)
##' @param nCores how many cores should be used for parallel computing?
##' Defaults to the number of cores on the machine (maximum 5)
##' @param \dots not used
##' @param derive a named list of functions which derives statistics, based on the
##' vector of posterior MTD samples. Each list element must therefore accept
##' one and only one argument, which is a numeric vector, and return a number.
##'
##' @return an object of class \code{\linkS4class{Simulations}}
##'
##' @example examples/design-method-simulate-DADesign.R
##' @export
##' @keywords methods
setMethod("simulate",
  signature =
    signature(
      object = "DADesign",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object, nsim = 1L, seed = NULL,
             truthTox, truthSurv, trueTmax = NULL, args = NULL, firstSeparate = FALSE,
             deescalate = TRUE,
             mcmcOptions = McmcOptions(),
             DA = TRUE,
             parallel = FALSE, nCores = min(parallel::detectCores(), 5),
             derive = list(),
             ...) {
      ## checks and extracts
      assert_function(truthTox)
      assert_function(truthSurv)
      assert_flag(firstSeparate)
      assert_count(nsim, positive = TRUE)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      args <- as.data.frame(args)
      nArgs <- max(nrow(args), 1L)

      ## seed handling
      RNGstate <- set_seed(seed)

      ## from this,
      ## generate the individual seeds for the simulation runs
      simSeeds <- sample(x = seq_len(1e5), size = as.integer(nsim))

      ## Define functions which are useful in DLT Surv generation
      inverse <- function(f, lower = -100, upper = 100) {
        function(y) {
          uniroot((function(x) f(x) - y),
            lower = lower, upper = upper
          )[1]$root
        }
      }

      ## The DLT window length
      thisData <- object@data
      Tmax <- thisData@Tmax

      if (is.null(trueTmax)) {
        trueTmax <- Tmax
      } else if (trueTmax < Tmax) {
        warning("trueTmax < Tmax! trueTmax is set to Tmax")
        trueTmax <- Tmax
      }

      ## Calculate the inverse function of Surv to DLT CDF
      itruthSurv <- inverse(truthSurv, 0, trueTmax)

      ## generate random variable of Surv to DLT data; return Tmax when no
      ## DLT
      rtruthSurv <- function(DLT, Tmax_, itruthSurv = itruthSurv) {
        u_i <- rep(-100, length(DLT)) # remember to check this

        if (sum(DLT == 0) > 0) {
          u_i[DLT == 0] <- Tmax_
        }

        if (sum(DLT == 1) > 0) {
          u_i[DLT == 1] <- unlist(lapply(runif(sum(DLT == 1), 0, 1), itruthSurv))
        }

        # make sure that results are always positive, otherwise we get
        # problems below.
        u_i[u_i == 0] <- 0.5
        return(u_i)
      }

      # A function to return follow up fulfull yes (TRUE) vs no (FALSE);
      ready_to_open <- function(day, window, thisSurv) {
        size <- length(thisSurv)
        # the date the patient starts;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # the relative time for each patient on the specified "date";
        individule_check <- day - cumsum(c(0, start_time))
        # the minial number should be 0;
        individule_check[individule_check < 0] <- 0
        follow_up <- apply(rbind(thisSurv, individule_check), 2, min)
        return(all((follow_up - apply(rbind(window$patientFollow, thisSurv), 2, min)) >= 0) & (max(follow_up) >= min(window$patientFollowMin, max(thisSurv))))
      }

      ## assume we have surfficient patients, i.e. patient can be immediately enrolled
      ## once the trial accumulation is open. This function will tell you when to open
      ## the next cohort;
      # this function applys to all trials;
      nextOpen <- function(window, thisSurv) {
        size <- length(thisSurv)

        window$patientGap <- window$patientGap[1:size] ## if length(window$pt)>length(thisSurv), assume the first length(thisSurv) patients were enrolled;
        ## if the DLT happens before the end of DLT window, then the next
        ## cohort/enrollment of the next patient would happened earlier;
        start_time <- apply(rbind(thisSurv[-size], window$patientGap[-1]), 2, min)
        # duration of the cohort (all DLT windows finished);
        maxT <- max(thisSurv + cumsum(c(0, start_time)))

        meetrequire <- sapply(1:maxT, function(i) {
          ready_to_open(i, window, thisSurv)
        })
        if (sum(meetrequire) > 0) {
          # the earliest time that the require is met;
          time <- min(c(1:maxT)[meetrequire])
        } else {
          time <- maxT
        }

        return(time)
      }

      ## the function to produce the run a single simulation
      ## with index "iterSim"
      runSim <- function(iterSim) {
        ## set the seed for this run
        set.seed(simSeeds[iterSim])

        # check<<-simSeeds[iterSim]
        ## what is now the argument for the truth?
        ## (appropriately recycled)
        thisArgs <- args[(iterSim - 1) %% nArgs + 1, , drop = FALSE]

        ## so this truth is...
        thisTruth <- function(dose) {
          do.call(
            truthTox,
            ## First argument: the dose
            c(
              dose,
              ## Following arguments
              thisArgs
            )
          )
        }

        ## start the simulated data with the provided one
        thisData <- object@data

        # In case there are placebo
        if (thisData@placebo) {
          ## what is the probability for tox. at placebo?
          thisProb.PL <- thisTruth(object@data@doseGrid[1])
        }

        ## shall we stop the trial?
        ## First, we want to continue with the starting dose.
        ## This variable is updated after each cohort in the loop.
        stopit <- FALSE

        ## the time clock for the study, set to 0 when the first simulated
        ## patient initially dosed;
        trialtime <- 0

        # initiate the true DLT, true DLT Surv and the C1/D1 for each patients
        factDLTs <- thisData@y
        factSurv <- thisData@u
        factT0 <- thisData@t0

        ## what is the next dose to be used?
        ## initialize with starting dose
        thisDose <- object@startingDose

        ## inside this loop we simulate the whole trial, until stopping
        while (!stopit) {
          ## what is the probability for tox. at this dose?
          thisProb <- thisTruth(thisDose)

          ## what is the cohort size at this dose?
          thisSize <- size(object@cohort_size,
            dose = thisDose,
            data = thisData
          )

          thisSafetywindow <- windowLength(object@safetyWindow, thisSize)
          # better: add a checkpoint in safetywindow--dim(safetywindow$pt)==thisSize;

          ## In case there are placebo
          if (thisData@placebo) {
            thisSize.PL <- size(object@pl_cohort_size,
              dose = thisDose,
              data = thisData
            )
          }


          ## simulate DLTs: depends on whether we
          ## separate the first patient or not.
          ## amended on May 24: if any patient had DLT before the
          ## first patient finished a staggered window
          ## further enrollment will be stopped;

          if (firstSeparate && (thisSize > 1L)) {
            ## dose the first patient
            thisDLTs <- rbinom(
              n = 1L,
              size = 1L,
              prob = thisProb
            )

            if (thisData@placebo) {
              thisDLTs.PL <- rbinom(
                n = 1L,
                size = 1L,
                prob = thisProb.PL
              )
            }

            thisSurv <- ceiling(rtruthSurv(DLT = thisDLTs, Tmax_ = trueTmax, itruthSurv = itruthSurv))

            if (Tmax < trueTmax) {
              thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

              thisSurv <- apply(rbind(thisSurv, rep(Tmax, length(thisSurv))), 2, min)
            }

            thisT0 <- trialtime

            ## if there is no DLT during Safety window:
            ## and no DLTs of previous patients-->


            # need to update the DataDA object
            tempData <- update(
              object = thisData,
              y = c(factDLTs, thisDLTs), #### the y will be updated according to u
              u = c(factSurv, thisSurv),
              t0 = c(factT0, thisT0),
              x = thisDose,
              trialtime = trialtime + thisSafetywindow$patientGap[2]
            ) #### the u will be updated over time

            temptime <- (tempData@u + tempData@t0)[tempData@y == 1 & tempData@x <= thisDose]


            # identify number of DLTs occurs during the thisSafetywindow$pt[2]
            # if(thisSurv>thisSafetywindow$pt[2])
            if (sum(temptime > trialtime) == 0) {
              ## enroll the remaining patients
              thisDLTs <- c(
                thisDLTs,
                rbinom(
                  n = thisSize - 1L,
                  size = 1L,
                  prob = thisProb
                )
              )

              thisSurv <- c(
                thisSurv,
                ceiling(rtruthSurv(thisDLTs[-1], trueTmax, itruthSurv = itruthSurv))
              )

              if (Tmax < trueTmax) {
                thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

                thisSurv <- apply(rbind(thisSurv, rep(Tmax, length(thisSurv))), 2, min)
              }

              # in case any DLT happens before the end of the safety window;
              real_window <- apply(rbind(thisSurv[-thisSize], thisSafetywindow$patientGap[-1]), 2, min)


              thisT0 <- trialtime + c(0, cumsum(real_window))

              if (thisData@placebo && (thisSize.PL > 1L)) {
                thisDLTs.PL <- c(
                  thisDLTs.PL,
                  rbinom(
                    n = thisSize.PL - 1L,
                    size = 1L,
                    prob = thisProb.PL
                  )
                )
              }
            }

            rm(tempData)
            rm(temptime)
          } else {
            ## we can directly dose all patients
            thisDLTs <- rbinom(
              n = thisSize,
              size = 1L,
              prob = thisProb
            )

            thisSurv <- ceiling(rtruthSurv(thisDLTs, trueTmax, itruthSurv = itruthSurv))
            ## should return a vector with a same dimention as thisDLTs
            if (Tmax < trueTmax) {
              thisDLTs[thisDLTs == 1 & thisSurv > Tmax] <- 0

              thisSurv <- apply(rbind(thisSurv, rep(Tmax, length(thisSurv))), 2, min)
            }
            # in case any DLT happens before the end of the safety window;
            real_window <- apply(rbind(thisSurv[-thisSize], thisSafetywindow$patientGap[-1]), 2, min)

            thisT0 <- trialtime + c(0, cumsum(real_window))
            ## should return a vector with a same dimention as thisDLTs

            if (thisData@placebo) {
              thisDLTs.PL <- rbinom(
                n = thisSize.PL,
                size = 1L,
                prob = thisProb.PL
              )
            }
          }


          ## update the data with this placebo (if any)
          ## cohort and then with active dose
          if (thisData@placebo) {
            thisData <- update(
              object = thisData,
              x = object@data@doseGrid[1],
              y = thisDLTs.PL
            )

            ## update the data with active dose
            thisData <- update(
              object = thisData,
              x = thisDose,
              y = thisDLTs,
              new_cohort = FALSE
            )

            ## JZ: additional part for DADesign--when to start the next cohort
            trialtime <- trialtime + nextOpen(
              window = thisSafetywindow,
              thisSurv = thisSurv
            )
          } else {
            ## JZ: since the whole y and u column need update.
            ## factDLTs and factSuev get update and then calculate the y and u value in
            ## thisData object
            #
            #                                                   ## update the data with this cohort
            #                                                   thisData <- update(object=thisData,
            #                                                                      x=thisDose,  ####the x will be constantly updated according to u
            #                                                                      y=thisDLTs,
            #                                                                      u=thisSurv)  ####the u will be constantly updated

            factDLTs <- c(factDLTs, thisDLTs)

            factSurv <- c(factSurv, thisSurv) # better: check the data type of factSurv and thisSurv;

            factT0 <- c(factT0, thisT0)


            tempnext <- nextOpen(
              window = thisSafetywindow,
              thisSurv = thisSurv
            )

            ##### if there are DLTs, patients in the higher cohorts will be dosed a lower dose or discontinue.
            if (deescalate == TRUE) {
              newDLTid <- ((factSurv + factT0) > trialtime & (factSurv + factT0 - trialtime) <= tempnext & factDLTs == 1)

              newDLTnum <- c(1:length(factDLTs))[newDLTid]

              newDLTnum <- newDLTnum[newDLTnum <= (length(factDLTs) - length(thisDLTs))]

              # if(ifelse(sum(newDLTnum)==0,Inf,min(newDLTnum))<=(length(factDLTs)-length(thisDLTs))){
              if (length(newDLTnum) > 0) {
                for (DLT_loop in newDLTnum) {
                  newDLTtime <- (factSurv + factT0)[DLT_loop]

                  # identify higher dose--impacted patients:
                  deescalateID <- c(DLT_loop:length(factDLTs))[c(thisData@x, rep(thisDose, length(thisDLTs)))[DLT_loop:length(factDLTs)] > thisData@x[DLT_loop]]


                  ## DLT will be observed once the followup time >= the time to DLT
                  factDLTs[deescalateID] <- as.integer(factDLTs * (newDLTtime >= factT0 + factSurv))[deescalateID]

                  ## update DLT free survival time
                  factSurv[deescalateID] <- apply(rbind(factSurv, newDLTtime - factT0), 2, min)[deescalateID]
                }

                tempnext <- min(tempnext, max((factSurv + factT0)[(length(factDLTs) - length(thisDLTs) + 1):length(factDLTs)]) - trialtime)
              }
            }






            ## JZ: future work: additional part for DADesign--when to start the next cohort
            ## nextOpen can be modified to incorporate different patient enrollment rate;
            ## currently assume we have sufficient patients;
            ## If there is a gap between cohorts for cohort manager meeting, it can be
            ## added to here;

            trialtime <- trialtime + tempnext



            ## Update thisData
            ## according to what can be observed by the time when the next cohort open;


            thisData <- update(
              object = thisData,
              y = factDLTs, #### the y will be updated according to u
              u = factSurv,
              t0 = factT0,
              x = thisDose,
              trialtime = trialtime
            ) #### the u will be updated over time

            try(if (length(thisData@x) != length(thisData@u) || length(thisData@u) != length(thisData@y)) {
              stop("x,y,u dimention error")
            })
          }


          # testthisdata<<-thisData

          ## what is the dose limit? #JZ should
          ## still work for the DataDA object
          doselimit <- maxDose(object@increments,
            data = thisData
          )



          ## generate samples from the model
          if (DA == TRUE) {
            thisSamples <- mcmc(
              data = thisData,
              model = object@model,
              options = mcmcOptions
            )
          } else if (DA == FALSE) {
            temp_model <- LogisticLogNormal(
              mean = object@model@params@mean,
              cov = object@model@params@cov,
              ref_dose = object@model@refDose
            )

            trunk_Data <- Data(
              x = thisData@x, y = thisData@y,
              doseGrid = thisData@doseGrid,
              cohort = thisData@cohort,
              ID = thisData@ID
            )

            thisSamples <- mcmc(
              data = trunk_Data,
              model = temp_model,
              options = mcmcOptions
            )
          }

          ## => what is the next best dose?
          thisDose <- nextBest(object@nextBest,
            doselimit = doselimit,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )$value

          ## evaluate stopping rules
          stopit <- stopTrial(object@stopping,
            dose = thisDose,
            samples = thisSamples,
            model = object@model,
            data = thisData
          )
          stopit_results <- h_unpack_stopit(stopit)
        }

        ## get the fit
        thisFit <- fit(
          object = thisSamples,
          model = object@model,
          data = thisData
        )

        # Get the MTD estimate from the samples.

        target_dose_samples <- dose(
          mean(object@nextBest@target),
          model = object@model,
          samples = thisSamples
        )

        # Create a function for additional statistical summary.
        additional_stats <- lapply(derive, function(f) f(target_dose_samples))

        ## return the results
        thisResult <-
          list(
            data = thisData,
            dose = thisDose,
            duration = trialtime,
            fit =
              subset(thisFit,
                select = c(middle, lower, upper)
              ),
            stop =
              attr(
                stopit,
                "message"
              ),
            report_results = stopit_results,
            additional_stats = additional_stats
          )
        return(thisResult)
      }

      resultList <- get_result_list(
        fun = runSim, ## remove
        nsim = nsim,
        vars =
          c(
            "simSeeds",
            "args",
            "nArgs",
            "firstSeparate",
            "truthTox",
            "truthSurv",
            "object",
            "mcmcOptions",
            "nextOpen",
            "ready_to_open"
          ),
        parallel = parallel,
        n_cores = nCores
      )

      ## put everything in the Simulations format:

      ## setup the list for the simulated data objects
      dataList <- lapply(resultList, "[[", "data")


      ## the vector of the final dose recommendations
      recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

      ## the vector of the final trial duration;
      trialduration <- as.numeric(sapply(resultList, "[[", "duration"))

      ## setup the list for the final fits
      fitList <- lapply(resultList, "[[", "fit")

      ## the reasons for stopping
      stopReasons <- lapply(resultList, "[[", "stop")

      # individual stopping rule results as matrix, labels as column names
      stop_results <- lapply(resultList, "[[", "report_results")
      stop_report <- as.matrix(do.call(rbind, stop_results))

      additional_stats <- lapply(resultList, "[[", "additional_stats")

      ## return the results in the Simulations class object
      ret <- DASimulations(
        data = dataList,
        doses = recommendedDoses,
        fit = fitList,
        trialduration = trialduration,
        stop_report = stop_report,
        stop_reasons = stopReasons,
        additional_stats = additional_stats,
        seed = RNGstate
      )


      return(ret)
    }
)

## --------------------------------------------------------------------------
# nolint end

# simulate ----

## DesignGrouped ----

#' Simulate Method for the [`DesignGrouped`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simulate method for [`DesignGrouped`] designs.
#'
#' @param object (`DesignGrouped`)\cr the design we want to simulate trials from.
#' @param nsim (`number`)\cr how many trials should be simulated.
#' @param seed (`RNGstate`)\cr generated with [set_seed()].
#' @param truth (`function`)\cr a function which takes as input a dose (vector) and
#'   returns the true probability (vector) for toxicity for the mono arm.
#'   Additional arguments can be supplied in `args`.
#' @param combo_truth (`function`)\cr same as `truth` but for the combo arm.
#' @param args (`data.frame`)\cr optional `data.frame` with arguments that work
#'   for both the `truth` and `combo_truth` functions. The column names correspond to
#'   the argument names, the rows to the values of the arguments. The rows are
#'   appropriately recycled in the `nsim` simulations.
#' @param firstSeparate (`flag`)\cr whether to enroll the first patient separately
#'   from the rest of the cohort and close the cohort in case a DLT occurs in this
#'   first patient.
#' @param mcmcOptions (`McmcOptions`)\cr MCMC options for each evaluation in the trial.
#' @param parallel (`flag`)\cr whether the simulation runs are parallelized across the
#'   cores of the computer.
#' @param nCores (`number`)\cr how many cores should be used for parallel computing.
#' @param ... not used.
#'
#' @return A list of `mono` and `combo` simulation results as [`Simulations`] objects.
#'
#' @aliases simulate-DesignGrouped
#' @export
#' @example examples/Design-method-simulate-DesignGrouped.R
#'
setMethod(
  "simulate",
  signature =
    signature(
      object = "DesignGrouped",
      nsim = "ANY",
      seed = "ANY"
    ),
  def =
    function(object,
             nsim = 1L,
             seed = NULL,
             truth,
             combo_truth,
             args = data.frame(),
             firstSeparate = FALSE,
             mcmcOptions = McmcOptions(),
             parallel = FALSE,
             nCores = min(parallelly::availableCores(), 5),
             ...) {
      nsim <- as.integer(nsim)
      assert_function(truth)
      assert_function(combo_truth)
      assert_data_frame(args)
      assert_count(nsim, positive = TRUE)
      assert_flag(firstSeparate)
      assert_flag(parallel)
      assert_count(nCores, positive = TRUE)

      n_args <- max(nrow(args), 1L)
      rng_state <- set_seed(seed)
      sim_seeds <- sample.int(n = 2147483647, size = nsim)

      run_sim <- function(iter_sim) {
        set.seed(sim_seeds[iter_sim])
        current <- list(mono = list(), combo = list())
        # Define true toxicity functions.
        current$args <- args[(iter_sim - 1) %% n_args + 1, , drop = FALSE]
        current$mono$truth <- function(dose) do.call(truth, c(dose, current$args))
        current$combo$truth <- function(dose) do.call(combo_truth, c(dose, current$args))
        # Start the simulated data with the provided one.
        current$mono$data <- object@mono@data
        current$combo$data <- object@combo@data
        # We are in the first cohort and continue for mono and combo.
        current$first <- TRUE
        current$mono$stop <- current$combo$stop <- FALSE

        # What are the next doses to be used? Initialize with starting doses.
        if (object@same_dose_for_all || (!object@first_cohort_mono_only && object@same_dose_for_start)) {
          current$mono$dose <- current$combo$dose <- min(object@mono@startingDose, object@combo@startingDose)
        } else {
          current$mono$dose <- object@mono@startingDose
          current$combo$dose <- object@combo@startingDose
        }

        # Inside this loop we simulate the whole trial, until stopping.
        while (!(current$mono$stop && current$combo$stop)) {
          if (!current$mono$stop) {
            cohort_size_mono <- size(
              object@mono@cohort_size,
              dose = current$mono$dose,
              data = current$mono$data
            )
            this_prob_mono <- current$mono$truth(current$mono$dose)
            current$mono$data <- current$mono$data %>%
              h_determine_dlts(
                dose = current$mono$dose,
                prob = this_prob_mono,
                cohort_size = cohort_size_mono,
                first_separate = firstSeparate
              )
          }
          if (!current$combo$stop && (!current$first || !object@first_cohort_mono_only)) {
            cohort_size_combo <- size(
              object@combo@cohort_size,
              dose = current$combo$dose,
              data = current$combo$data
            )
            this_prob_combo <- current$combo$truth(current$combo$dose)
            current$combo$data <- current$combo$data %>%
              h_determine_dlts(
                dose = current$combo$dose,
                prob = this_prob_combo,
                cohort_size = cohort_size_combo,
                first_separate = firstSeparate
              )
          }

          current$grouped <- h_group_data(current$mono$data, current$combo$data)
          current$samples <- mcmc(current$grouped, object@model, mcmcOptions)
          if (!current$mono$stop) {
            current$mono$limit <- maxDose(object@mono@increments, data = current$mono$data)
            current$mono$dose <- object@mono@nextBest %>%
              nextBest(current$mono$limit, current$samples, object@model, current$grouped, group = "mono")
            current$mono$dose <- current$mono$dose$value
          }
          if (!current$combo$stop && (!current$first || !object@first_cohort_mono_only)) {
            current$combo$limit <- if (is.na(current$mono$dose)) {
              0
            } else {
              maxDose(object@combo@increments, current$combo$data) %>%
                min(current$mono$dose, na.rm = TRUE)
            }
            current$combo$dose <- object@combo@nextBest %>%
              nextBest(current$combo$limit, current$samples, object@model, current$grouped, group = "combo")
            current$combo$dose <- current$combo$dose$value
            current$combo$stop <- object@combo@stopping %>%
              stopTrial(current$combo$dose, current$samples, object@model, current$combo$data, group = "combo")
            current$combo$results <- h_unpack_stopit(current$combo$stop)
          }
          if (!current$mono$stop) {
            current$mono$stop <- object@mono@stopping %>%
              stopTrial(
                current$mono$dose, current$samples, object@model, current$mono$data,
                group = "mono", external = current$combo$stop
              )
            current$mono$results <- h_unpack_stopit(current$mono$stop)
          }
          if (object@same_dose_for_all && !current$mono$stop && !current$combo$stop) {
            current$mono$dose <- current$combo$dose <- min(current$mono$dose, current$combo$dose)
          }
          if (current$first) {
            current$first <- FALSE
            if (object@first_cohort_mono_only && object@same_dose_for_start) {
              current$mono$dose <- current$combo$dose <- min(current$mono$dose, current$combo$dose)
            }
          }
        }
        current$mono$fit <- fit(current$samples, object@model, current$grouped, group = "mono")
        current$combo$fit <- fit(current$samples, object@model, current$grouped, group = "combo")
        lapply(
          X = current[c("mono", "combo")], FUN = with,
          list(
            data = data, dose = dose, fit = subset(fit, select = -dose),
            stop = attr(stop, "message"), results = results
          )
        )
      }
      vars_needed <- c("simSeeds", "args", "nArgs", "truth", "combo_truth", "firstSeparate", "object", "mcmcOptions")

      result_list <- get_result_list(run_sim, nsim, vars_needed, parallel, nCores)
      # Now we have a list with each element containing mono and combo. Reorder this a bit:
      result_list <- list(
        mono = lapply(result_list, "[[", "mono"),
        combo = lapply(result_list, "[[", "combo")
      )
      # Put everything in a list with both mono and combo Simulations:
      lapply(result_list, function(this_list) {
        data_list <- lapply(this_list, "[[", "data")
        recommended_doses <- as.numeric(sapply(this_list, "[[", "dose"))
        fit_list <- lapply(this_list, "[[", "fit")
        stop_reasons <- lapply(this_list, "[[", "stop")
        report_results <- lapply(this_list, "[[", "results")
        stop_report <- as.matrix(do.call(rbind, report_results))
        additional_stats <- lapply(this_list, "[[", "additional_stats")


        Simulations(
          data = data_list,
          doses = recommended_doses,
          fit = fit_list,
          stop_reasons = stop_reasons,
          stop_report = stop_report,
          additional_stats = additional_stats,
          seed = rng_state
        )
      })
    }
)

# tidy ----

## tidy-DualDesign ----

#' @rdname tidy
#' @aliases tidy-DualDesign
#' @example examples/Design-method-tidyDualDesign.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "DualDesign"),
  definition = function(x, ...) {
    # Some Design objects have complex attributes whose structure is not supported.
    rv <- h_tidy_all_slots(x, attributes = FALSE) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

#' @include checkmate.R
#' @include Model-methods.R
#' @include Samples-class.R
#' @include Rules-class.R
#' @include helpers.R
#' @include helpers_rules.R
#' @include helpers_broom.R
NULL

# nextBest ----

## generic ----

#' Finding the Next Best Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the recommended next best dose based on the
#' corresponding rule `nextBest`, the posterior `samples` from the `model` and
#' the underlying `data`.
#'
#' @param nextBest (`NextBest`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose. If it is an
#'   infinity (default), then essentially no dose limit will be applied in the
#'   course of dose recommendation calculation.
#' @param samples (`Samples`)\cr posterior samples from `model` parameters given
#'   `data`.
#' @param model (`GeneralModel`)\cr model that was used to generate the samples.
#' @param data (`Data`)\cr data that was used to generate the samples.
#' @param ... additional arguments without method dispatch.
#'
#' @return A list with the next best dose recommendation  (element named `value`)
#'   from the grid defined in `data`, and a plot depicting this recommendation
#'   (element named `plot`). In case of multiple plots also an element
#'   named `singlePlots` is included. The `singlePlots` is itself a list with
#'   single plots. An additional list with elements describing the outcome
#'   of the rule can be contained too.
#'
#' @export
#'
setGeneric(
  name = "nextBest",
  def = function(nextBest, doselimit, samples, model, data, ...) {
    if (!missing(doselimit)) {
      assert_number(doselimit, lower = 0, finite = FALSE)
    }
    standardGeneric("nextBest")
  },
  valueClass = "list"
)

## NextBestMTD ----

#' @describeIn nextBest find the next best dose based on the MTD rule.
#'
#' @aliases nextBest-NextBestMTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMTD",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Generate the MTD samples and derive the next best dose.
    dose_target_samples <- dose(x = nextBest@target, model, samples, ...)
    dose_target <- nextBest@derive(dose_target_samples)

    # Round to the next possible grid point.
    doses_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo)
    next_dose_level <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = dose_target_samples),
      aes(.data$x),
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_density() +
      coord_cartesian(xlim = range(data@doseGrid)) +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("MTD") +
      ylab("Posterior density")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(value = next_dose, plot = p)
  }
)

## NextBestNCRM ----

#' @describeIn nextBest find the next best dose based on the NCRM method. The
#'   additional element `probs` in the output's list contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestNCRM
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    # Estimates of posterior probabilities that are based on the prob. samples
    # which are within overdose/target interval.
    prob_overdose <- colMeans(h_in_range(prob_samples, nextBest@overdose, bounds_closed = c(FALSE, TRUE)))
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE) &
      (prob_overdose <= nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher than some numerical threshold,
      # then take that level, otherwise stick to the maximum level that is OK.
      # next_best_level is relative to eligible doses.
      next_best_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > 0.05),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      coord_cartesian(ylim = c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 + geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(xintercept = data@doseGrid[sum(is_dose_eligible)], lwd = 1.1, lty = 2, colour = "red") +
        geom_point(
          data = data.frame(x = next_dose, y = prob_target[is_dose_eligible][next_best_level] * 100 + 0.03),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(yintercept = nextBest@max_overdose_prob * 100, lwd = 1.1, lty = 2, colour = "black") +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(
        dose = data@doseGrid,
        target = prob_target,
        overdose = prob_overdose
      )
    )
  }
)

## NextBestNCRM-DataParts ----

#' @describeIn nextBest find the next best dose based on the NCRM method when
#'   two parts trial is used.
#'
#' @aliases nextBest-NextBestNCRM-DataParts
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRM-DataParts.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestNCRM",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "DataParts"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Exception when we are in part I or about to start part II!
    if (all(data@part == 1L)) {
      # Propose the highest possible dose (assuming that the dose limit came
      # from reasonable increments rule, i.e. incrementsRelativeParts).
      if (is.infinite(doselimit)) {
        stop("A finite doselimit needs to be specified for Part I.")
      }
      list(value = doselimit, plot = NULL)
    } else {
      # Otherwise we will just do the standard thing.
      callNextMethod(nextBest, doselimit, samples, model, data, ...)
    }
  }
)

## NextBestNCRMLoss ----

#' @describeIn nextBest find the next best dose based on the NCRM method and
#'   loss function.
#'
#' @aliases nextBest-NextBestNCRMLoss
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestNCRMLoss.R
#'
setMethod("nextBest",
  signature = signature(
    nextBest = "NextBestNCRMLoss",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
    # Compute probabilities to be in target and overdose tox interval.
    prob_underdosing <- colMeans(prob_samples < nextBest@target[1])
    prob_target <- colMeans(h_in_range(prob_samples, nextBest@target))
    prob_overdose <- colMeans(h_in_range(prob_samples, nextBest@overdose, bounds_closed = c(FALSE, TRUE)))
    prob_mean <- colMeans(prob_samples)
    prob_sd <- apply(prob_samples, 2, stats::sd)

    is_unacceptable_specified <- any(nextBest@unacceptable != c(1, 1))

    prob_mat <- if (!is_unacceptable_specified) {
      cbind(underdosing = prob_underdosing, target = prob_target, overdose = prob_overdose)
    } else {
      prob_unacceptable <- colMeans(
        h_in_range(prob_samples, nextBest@unacceptable, bounds_closed = c(FALSE, TRUE))
      )
      prob_excessive <- prob_overdose
      prob_overdose <- prob_excessive + prob_unacceptable
      cbind(
        underdosing = prob_underdosing,
        target = prob_target,
        excessive = prob_excessive,
        unacceptable = prob_unacceptable
      )
    }

    posterior_loss <- as.vector(nextBest@losses %*% t(prob_mat))
    names(posterior_loss) <- data@doseGrid

    probs <- cbind(
      dose = data@doseGrid,
      prob_mat = prob_mat,
      mean = prob_mean,
      std_dev = prob_sd,
      posterior_loss = posterior_loss
    )

    # Eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE) &
      (prob_overdose < nextBest@max_overdose_prob)

    # Next best dose is the dose with the minimum loss function.
    next_dose <- if (any(is_dose_eligible)) {
      next_best_level <- which.min(posterior_loss[is_dose_eligible])
      data@doseGrid[is_dose_eligible][next_best_level]
    } else {
      NA_real_
    }

    # Build plot.
    p <- h_next_best_ncrm_loss_plot(
      prob_mat = prob_mat,
      posterior_loss = posterior_loss,
      max_overdose_prob = nextBest@max_overdose_prob,
      dose_grid = data@doseGrid,
      max_eligible_dose_level = sum(is_dose_eligible),
      doselimit = doselimit,
      next_dose = next_dose,
      is_unacceptable_specified = is_unacceptable_specified
    )

    c(list(value = next_dose, probs = probs), p)
  }
)

## NextBestThreePlusThree ----

#' @describeIn nextBest find the next best dose based on the 3+3 method.
#'
#' @aliases nextBest-NextBestThreePlusThree
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestThreePlusThree.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestThreePlusThree",
    doselimit = "missing",
    samples = "missing",
    model = "missing",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # The last dose level tested (not necessarily the maximum one).
    last_level <- tail(data@xLevel, 1L)

    # Get number of patients per grid's dose and DLT rate at the last level.
    nPatients <- table(factor(data@x, levels = data@doseGrid))
    n_dlts_last_level <- sum(data@y[data@xLevel == last_level])
    dlt_rate_last_level <- n_dlts_last_level / nPatients[last_level]

    level_change <- if (dlt_rate_last_level < 1 / 3) {
      # Escalate it, unless this is the highest level or the higher dose was already tried.
      ifelse((last_level == data@nGrid) || (nPatients[last_level + 1L] > 0), 0L, 1L)
    } else {
      # Rate is too high, deescalate it, unless an edge case of 1/3, where the decision
      # depends on the num. of patients: if >3, then deescalate it, otherwise stay.
      ifelse((dlt_rate_last_level == 1 / 3) && (nPatients[last_level] <= 3L), 0L, -1L)
    }
    next_dose_level <- last_level + level_change

    # Do we stop here? Only if we have no MTD, or the next level has been tried
    # enough (more than three patients already).
    if (next_dose_level == 0L) {
      next_dose <- NA
      stop_here <- TRUE
    } else {
      next_dose <- data@doseGrid[next_dose_level]
      stop_here <- nPatients[next_dose_level] > 3L
    }

    list(value = next_dose, stopHere = stop_here)
  }
)

## NextBestDualEndpoint ----

#' @describeIn nextBest find the next best dose based on the dual endpoint
#'   model. The additional list element `probs` contains the target and
#'   overdosing probabilities (across all doses in the dose grid) used in the
#'   derivation of the next best dose.
#'
#' @aliases nextBest-NextBestDualEndpoint
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestDualEndpoint.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestDualEndpoint",
    doselimit = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Biomarker samples at the dose grid points.
    biom_samples <- samples@data$betaW

    prob_target <- if (nextBest@target_relative) {
      # If 'Emax' parameter available, target biomarker level will be relative to 'Emax',
      # otherwise, it will be relative to the maximum biomarker level achieved
      # in dose range for a given sample.
      if ("Emax" %in% names(samples)) {
        lwr <- nextBest@target[1] * samples@data$Emax
        upr <- nextBest@target[2] * samples@data$Emax
        colMeans(apply(biom_samples, 2L, function(s) (s >= lwr) & (s <= upr)))
      } else {
        target_levels <- apply(biom_samples, 1L, function(x) {
          rng <- range(x)
          min(which(h_in_range(x, nextBest@target * diff(rng) + rng[1] + c(0, 1e-10), bounds_closed = c(FALSE, TRUE))))
        })
        prob_target <- as.vector(table(factor(target_levels, levels = 1:data@nGrid)))
        prob_target / nrow(biom_samples)
      }
    } else {
      colMeans(h_in_range(biom_samples, nextBest@target))
    }

    # Now, compute probabilities to be in overdose tox interval, then flag
    # eligible grid doses after accounting for maximum possible dose and discarding overdoses.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples)
    prob_overdose <- colMeans(h_in_range(prob_samples, nextBest@overdose, bounds_closed = c(FALSE, TRUE)))

    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE) &
      (prob_overdose < nextBest@max_overdose_prob)

    next_dose <- if (any(is_dose_eligible)) {
      # If maximum target probability is higher the threshold, then take that
      # level, otherwise stick to the maximum level that is eligible.
      # next_dose_level is relative to eligible doses.
      next_dose_level <- ifelse(
        test = any(prob_target[is_dose_eligible] > nextBest@target_thresh),
        yes = which.max(prob_target[is_dose_eligible]),
        no = sum(is_dose_eligible)
      )
      data@doseGrid[is_dose_eligible][next_dose_level]
    } else {
      NA_real_
    }

    # Build plots, first for the target probability.
    p1 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_target * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "darkgreen",
        fill = "darkgreen"
      ) +
      ylim(c(0, 100)) +
      ylab(paste("Target probability [%]"))

    if (is.finite(doselimit)) {
      p1 <- p1 + geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
    }

    if (any(is_dose_eligible)) {
      p1 <- p1 +
        geom_vline(xintercept = data@doseGrid[sum(is_dose_eligible)], lwd = 1.1, lty = 2, colour = "red") +
        geom_point(
          data = data.frame(x = next_dose, y = prob_target[is_dose_eligible][next_dose_level] * 100 + 0.03),
          aes(x = x, y = y),
          size = 3,
          pch = 25,
          col = "red",
          bg = "red"
        )
    }

    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = data@doseGrid, y = prob_overdose * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(data@doseGrid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(yintercept = nextBest@max_overdose_prob * 100, lwd = 1.1, lty = 2, colour = "black") +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Place them below each other.
    plot_joint <- gridExtra::arrangeGrob(p1, p2, nrow = 2)

    list(
      value = next_dose,
      plot = plot_joint,
      singlePlots = list(plot1 = p1, plot2 = p2),
      probs = cbind(dose = data@doseGrid, target = prob_target, overdose = prob_overdose)
    )
  }
)

## NextBestMinDist ----

#' @describeIn nextBest gives the dose which is below the dose limit and has an
#'   estimated DLT probability which is closest to the target dose.
#'
#' @aliases nextBest-NextBestMinDist
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)
    dlt_prob <- colMeans(prob_samples)

    # Determine the dose with the closest distance.
    dose_target <- data@doseGrid[which.min(abs(dlt_prob - nextBest@target))]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    p <- ggplot(
      data = data.frame(x = data@doseGrid, y = dlt_prob),
      aes(.data$x, .data$y),
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_line() +
      geom_point() +
      coord_cartesian(xlim = range(data@doseGrid)) +
      scale_x_continuous(
        labels = as.character(data@doseGrid),
        breaks = data@doseGrid,
        guide = guide_axis(check.overlap = TRUE)
      ) +
      geom_hline(yintercept = nextBest@target, linetype = "dotted") +
      geom_vline(xintercept = dose_target, colour = "black", lwd = 1.1) +
      geom_text(
        data = data.frame(x = dose_target),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = 0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab("Posterior toxicity probability")

    if (is.finite(doselimit)) {
      p <- p +
        geom_vline(xintercept = doselimit, colour = "red", lwd = 1.1) +
        geom_text(
          data = data.frame(x = doselimit),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -0.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
      geom_text(
        data = data.frame(x = next_dose),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -1.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      probs = cbind(dose = data@doseGrid, dlt_prob = dlt_prob),
      plot = p
    )
  }
)

## NextBestInfTheory ----

#' @describeIn nextBest gives the appropriate dose within an information
#'   theoretic framework.
#'
#' @aliases nextBest-NextBestInfTheory
#'
#' @export
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestInfTheory",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    criterion <- colMeans(h_info_theory_dist(prob_samples, nextBest@target, nextBest@asymmetry))

    is_dose_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo, levels = TRUE)
    doses_eligible <- data@doseGrid[is_dose_eligible]
    next_best_level <- which.min(criterion[is_dose_eligible])
    next_best <- doses_eligible[next_best_level]
    list(value = next_best)
  }
)

## NextBestTD ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object without DLT samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestTD
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTD.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTD",
    doselimit = "numeric",
    samples = "missing",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, model, data, in_sim = FALSE, ...) {
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the next best doses in the doseGrid. The next best dose is the dose
    # at level closest and below the target dose estimate.
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo)

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # Find the variance of the log of the dose_target_eot.
    mat <- matrix(
      c(
        -1 / (model@phi2),
        -(log(prob_target_eot / (1 - prob_target_eot)) - model@phi1) / (model@phi2)^2
      ),
      nrow = 1
    )
    var_dose_target_eot <- as.vector(mat %*% model@Pcov %*% t(mat))

    # 95% credibility interval.
    ci_dose_target_eot <- exp(log(dose_target_eot) + c(-1, 1) * 1.96 * sqrt(var_dose_target_eot))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_td_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      data = data,
      prob_dlt = prob(dose = data@doseGrid, model = model, ...),
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    if (!h_in_range(dose_target_drt, range = dose_grid_range(data), bounds_closed = TRUE) && !in_sim) {
      warning(paste("TD", prob_target_drt * 100, "=", dose_target_drt, "not within dose grid"))
    }
    if (!h_in_range(dose_target_eot, range = dose_grid_range(data), bounds_closed = TRUE) && !in_sim) {
      warning(paste("TD", prob_target_eot * 100, "=", dose_target_eot, "not within dose grid"))
    }

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestTDsamples ----

#' @describeIn nextBest find the next best dose based only on the DLT responses
#'   and for [`LogisticIndepBeta`] model class object involving DLT samples.
#'
#' @aliases nextBest-NextBestTDsamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestTDsamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestTDsamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticIndepBeta",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, in_sim, ...) {
    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the nextBest@prob_target_drt
    # (or nextBest@prob_target_eot, respectively).
    dose_target_drt_samples <- dose(x = nextBest@prob_target_drt, model, samples, ...)
    dose_target_eot_samples <- dose(x = nextBest@prob_target_eot, model, samples, ...)

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Find the next doses in the doseGrid. The next dose is the dose at level
    # closest and below the dose_target_drt (or dose_target_eot, respectively).
    # h_find_interval assumes that elements in doses_eligible are strictly increasing.
    doses_eligible <- h_next_best_eligible_doses(data@doseGrid, doselimit, data@placebo)

    next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
    next_dose_drt <- doses_eligible[next_dose_lev_drt]

    next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
    next_dose_eot <- doses_eligible[next_dose_lev_eot]

    # 95% credibility interval.
    ci_dose_target_eot <- as.numeric(quantile(dose_target_eot_samples, probs = c(0.025, 0.975)))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_tdsamples_plot(
      dose_target_drt_samples = dose_target_drt_samples,
      dose_target_eot_samples = dose_target_eot_samples,
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_grid_range = range(data@doseGrid),
      nextBest = nextBest,
      doselimit = doselimit,
      next_dose = next_dose_drt
    )

    list(
      next_dose_drt = next_dose_drt,
      prob_target_drt = nextBest@prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_eot = next_dose_eot,
      prob_target_eot = nextBest@prob_target_eot,
      dose_target_eot = dose_target_eot,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      plot = p
    )
  }
)

## NextBestMaxGain ----

#' @describeIn nextBest find the next best dose based only on pseudo DLT model
#'   [`ModelTox`] and [`Effloglog`] efficacy model without samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGain
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGain.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGain",
    doselimit = "numeric",
    samples = "missing",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(nextBest, doselimit = Inf, model, data, model_eff, in_sim = FALSE, ...) {
    assert_class(model_eff, "Effloglog")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Target dose estimates, i.e. the dose with probability of the occurrence of
    # a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt <- dose(x = prob_target_drt, model, ...)
    dose_target_eot <- dose(x = prob_target_eot, model, ...)

    # Find the dose which gives the maximum gain.
    dosegrid_range <- dose_grid_range(data)
    opt <- optim(
      par = dosegrid_range[1],
      fn = function(DOSE) {
        -gain(DOSE, model_dle = model, model_eff = model_eff, ...)
      },
      method = "L-BFGS-B",
      lower = dosegrid_range[1],
      upper = dosegrid_range[2]
    )
    dose_mg <- opt$par # this is G*. # no lintr
    max_gain <- -opt$value

    # Print info message if dose target is outside of the range.
    if (!h_in_range(dose_target_drt, range = dose_grid_range(data), bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_drt * 100, "=", dose_target_drt, "not within dose grid"))
    }
    if (!h_in_range(dose_target_eot, range = dose_grid_range(data), bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_eot * 100, "=", dose_target_eot, "not within dose grid"))
    }
    if (!h_in_range(dose_mg, range = dose_grid_range(data), bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci <- h_next_best_mg_ci(
      dose_target = dose_target_eot,
      dose_mg = dose_mg,
      prob_target = prob_target_eot,
      placebo = data@placebo,
      model = model,
      model_eff = model_eff
    )

    # Build plot.
    p <- h_next_best_mg_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      max_gain = max_gain,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      data = data,
      model = model,
      model_eff = model_eff
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci$ci_dose_target,
      ci_ratio_dose_target_eot = ci$ci_ratio_dose_target,
      ci_dose_max_gain = ci$ci_dose_mg,
      ci_ratio_dose_max_gain = ci$ci_ratio_dose_mg,
      plot = p
    )
  }
)

## NextBestMaxGainSamples ----

#' @describeIn nextBest find the next best dose based on DLT and efficacy
#'   responses with DLT and efficacy samples.
#'
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog` or `EffFlexi`)\cr the efficacy model.
#' @param samples_eff (`Samples`)\cr posterior samples from `model_eff` parameters
#'   given `data`.
#' @param in_sim (`flag`)\cr is this method used in simulations? Default as `FALSE`.
#'   If this flag is `TRUE` and target dose estimates (during trial and end-of-trial)
#'   are outside of the dose grid range, the information message is printed by
#'   this method.
#'
#' @aliases nextBest-NextBestMaxGainSamples
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestMaxGainSamples.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestMaxGainSamples",
    doselimit = "numeric",
    samples = "Samples",
    model = "ModelTox",
    data = "DataDual"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, model_eff, samples_eff, in_sim = FALSE, ...) {
    assert_true(test_class(model_eff, "Effloglog") || test_class(model_eff, "EffFlexi"))
    assert_class(samples_eff, "Samples")
    assert_flag(in_sim)

    # 'drt' - during the trial, 'eot' end of trial.
    prob_target_drt <- nextBest@prob_target_drt
    prob_target_eot <- nextBest@prob_target_eot

    # Generate target dose samples, i.e. the doses with probability of the
    # occurrence of a DLT that equals to the prob_target_drt or prob_target_eot.
    dose_target_drt_samples <- dose(x = prob_target_drt, model, samples = samples, ...)
    dose_target_eot_samples <- dose(x = prob_target_eot, model, samples = samples, ...)

    # Derive the prior/posterior estimates based on two above samples.
    dose_target_drt <- nextBest@derive(dose_target_drt_samples)
    dose_target_eot <- nextBest@derive(dose_target_eot_samples)

    # Gain samples.
    gain_samples <- sapply(data@doseGrid, gain, model, samples, model_eff, samples_eff, ...)
    # For every sample, get the dose (from the dose grid) that gives the maximum gain value.
    dose_lev_mg_samples <- apply(gain_samples, 1, which.max)
    dose_mg_samples <- data@doseGrid[dose_lev_mg_samples]
    # Maximum gain dose estimate is the nth percentile of the maximum gain dose samples.
    dose_mg <- nextBest@mg_derive(dose_mg_samples)
    gain_values <- apply(gain_samples, 2, FUN = nextBest@mg_derive)

    # Print info message if dose target is outside of the range.
    dosegrid_range <- dose_grid_range(data)
    if (!h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_drt * 100, "=", dose_target_drt, "not within dose grid"))
    }
    if (!h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated TD", prob_target_eot * 100, "=", dose_target_eot, "not within dose grid"))
    }
    if (!h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE) && !in_sim) {
      print(paste("Estimated max gain dose =", dose_mg, "not within dose grid"))
    }

    # Get closest grid doses for a given target doses.
    nb_doses_at_grid <- h_next_best_mg_doses_at_grid(
      dose_target_drt = dose_target_drt,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_grid = data@doseGrid,
      doselimit = doselimit,
      placebo = data@placebo
    )

    # 95% credibility intervals and corresponding ratios for maximum gain dose and target dose eot.
    ci_dose_mg <- as.numeric(quantile(dose_mg_samples, probs = c(0.025, 0.975)))
    cir_dose_mg <- ci_dose_mg[2] / ci_dose_mg[1]

    ci_dose_target_eot <- as.numeric(quantile(dose_target_eot, probs = c(0.025, 0.975)))
    cir_dose_target_eot <- ci_dose_target_eot[2] / ci_dose_target_eot[1]

    # Build plot.
    p <- h_next_best_mgsamples_plot(
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      dose_mg = dose_mg,
      dose_mg_samples = dose_mg_samples,
      next_dose = nb_doses_at_grid$next_dose,
      doselimit = doselimit,
      dose_grid_range = dosegrid_range
    )

    list(
      next_dose = nb_doses_at_grid$next_dose,
      prob_target_drt = prob_target_drt,
      dose_target_drt = dose_target_drt,
      next_dose_drt = nb_doses_at_grid$next_dose_drt,
      prob_target_eot = prob_target_eot,
      dose_target_eot = dose_target_eot,
      next_dose_eot = nb_doses_at_grid$next_dose_eot,
      dose_max_gain = dose_mg,
      next_dose_max_gain = nb_doses_at_grid$next_dose_mg,
      ci_dose_target_eot = ci_dose_target_eot,
      ci_ratio_dose_target_eot = cir_dose_target_eot,
      ci_dose_max_gain = ci_dose_mg,
      ci_ratio_dose_max_gain = cir_dose_mg,
      plot = p
    )
  }
)

## NextBestProbMTDLTE ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate less or equal to the target toxicity
#'  level.
#'
#' @aliases nextBest-NextBestProbMTDLTE
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMTDLTE.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDLTE",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    # Determine the maximum dose level with a toxicity probability below or
    # equal to the target and calculate how often a dose is selected as MTD
    # across iterations.
    # The first element of the vector is the relative frequency that no
    # dose in the grid is below or equal to the target, the
    # second element that the 1st dose of the grid is the MTD, etc..
    prob_mtd_lte <- prop.table(
      table(factor(
        rowSums(prob_samples <= nextBest@target),
        levels = 0:data@nGrid
      ))
    )

    allocation_crit <- as.vector(prob_mtd_lte)
    names(allocation_crit) <- as.character(c(0, data@doseGrid))

    # In case that placebo is used, placebo and the portion that is not assigned
    # to any dose of the grid are merged.
    if (data@placebo) {
      allocation_crit[1] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-2]
    }

    # Handling of the portion that is not assigned to an active dose of
    # the dose grid. The portion is added to the minimum active dose
    # of the dose grid.
    allocation_crit[2] <- sum(allocation_crit[1:2])
    allocation_crit <- allocation_crit[-1]

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && (data@doseGrid[1] == next_dose)) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data,
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(drop = FALSE, guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))

    if (is.finite(doselimit)) {
      doselimit_level <- if (sum(allocation_crit_dose == doselimit) > 0) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(test = data@placebo && (data@doseGrid[1] == next_dose),
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red", lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue", lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(dose = allocation_crit_dose, allocation = allocation_crit),
      plot = p
    )
  }
)

## NextBestProbMTDMinDist ----

#' @describeIn nextBest find the next best dose based with the highest
#'  probability of having a toxicity rate with minimum distance to the
#'  target toxicity level.
#'
#' @aliases nextBest-NextBestProbMTDMinDist
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestProbMtdMinDist.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestProbMTDMinDist",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit, samples, model, data, ...) {
    # Matrix with samples from the dose-tox curve at the dose grid points.
    prob_samples <- sapply(data@doseGrid, prob, model = model, samples = samples, ...)

    # Determine which dose level has the minimum distance to target.
    dose_min_mtd_dist <- apply(
      prob_samples, 1, function(x) which.min(abs(x - nextBest@target))
    )

    allocation_crit <- prop.table(
      table(factor(dose_min_mtd_dist, levels = 1:data@nGrid))
    )
    names(allocation_crit) <- as.character(data@doseGrid)

    # In case that placebo is used, placebo and the first non-placebo dose
    # of the grid are merged.
    if (data@placebo) {
      allocation_crit[2] <- sum(allocation_crit[1:2])
      allocation_crit <- allocation_crit[-1]
    }

    # Determine the dose with the highest relative frequency.
    allocation_crit_dose <- as.numeric(names(allocation_crit))
    dose_target <- allocation_crit_dose[which.max(allocation_crit)]

    # Determine next dose.
    doses_eligible <- h_next_best_eligible_doses(
      data@doseGrid,
      doselimit,
      data@placebo
    )
    next_dose_level_eligible <- which.min(abs(doses_eligible - dose_target))
    next_dose <- doses_eligible[next_dose_level_eligible]

    # Create a plot.
    plt_data <- if (data@placebo && data@doseGrid[1] == next_dose) {
      data.frame(
        x = as.factor(data@doseGrid),
        y = c(0, as.numeric(allocation_crit)) * 100
      )
    } else {
      data.frame(
        x = as.factor(allocation_crit_dose),
        y = as.numeric(allocation_crit) * 100
      )
    }

    p <- ggplot(
      data = plt_data,
      fill = "grey50",
      colour = "grey50"
    ) +
      geom_col(aes(x, y), fill = "grey75") +
      scale_x_discrete(guide = guide_axis(check.overlap = TRUE)) +
      geom_vline(
        xintercept = as.factor(dose_target),
        lwd = 1.1,
        colour = "black"
      ) +
      geom_text(
        data = data.frame(x = as.factor(dose_target)),
        aes(.data$x, 0),
        label = "Est",
        vjust = -0.5,
        hjust = -0.5,
        colour = "black",
        angle = 90
      ) +
      xlab("Dose") +
      ylab(paste("Allocation criterion [%]"))


    if (is.finite(doselimit)) {
      doselimit_level <- if (any(allocation_crit_dose == doselimit)) {
        which(allocation_crit_dose == doselimit)
      } else {
        ifelse(test = data@placebo && data@doseGrid[1] == next_dose,
          yes = 1.5,
          no = sum(allocation_crit_dose < doselimit) + 0.5
        )
      }

      p <- p +
        geom_vline(
          xintercept = doselimit_level,
          colour = "red", lwd = 1.1
        ) +
        geom_text(
          data = data.frame(x = doselimit_level),
          aes(.data$x, 0),
          label = "Max",
          vjust = -0.5,
          hjust = -1.5,
          colour = "red",
          angle = 90
        )
    }

    p <- p +
      geom_vline(
        xintercept = as.factor(next_dose),
        colour = "blue", lwd = 1.1
      ) +
      geom_text(
        data = data.frame(x = as.factor(next_dose)),
        aes(.data$x, 0),
        label = "Next",
        vjust = -0.5,
        hjust = -2.5,
        colour = "blue",
        angle = 90
      )

    list(
      value = next_dose,
      allocation = cbind(dose = allocation_crit_dose, allocation = allocation_crit),
      plot = p
    )
  }
)

## NextBestOrdinal ----

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "Data"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    stop(
      paste0(
        "NextBestOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)

#' @describeIn nextBest find the next best dose for ordinal CRM models.
#'
#' @aliases nextBest-NextBestOrdinal
#'
#' @export
#' @example examples/Rules-method-nextBest-NextBestOrdinal.R
#'
setMethod(
  f = "nextBest",
  signature = signature(
    nextBest = "NextBestOrdinal",
    doselimit = "numeric",
    samples = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(nextBest, doselimit = Inf, samples, model, data, ...) {
    nextBest(
      nextBest = nextBest@rule,
      doselimit = doselimit,
      samples = h_convert_ordinal_samples(samples, nextBest@grade),
      model = h_convert_ordinal_model(model, nextBest@grade),
      data = h_convert_ordinal_data(data, nextBest@grade),
      ...
    )
  }
)

# maxDose ----

## generic ----

#' Determine the Maximum Possible Next Dose
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function determines the upper limit of the next dose based on the
#' `increments`and the `data`.
#'
#' @param increments (`Increments`)\cr the rule for the next best dose.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return A `number`, the maximum possible next dose.
#'
#' @export
#'
setGeneric(
  name = "maxDose",
  def = function(increments, data, ...) {
    standardGeneric("maxDose")
  },
  valueClass = "numeric"
)

## IncrementsRelative ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments.
#'
#' @aliases maxDose-IncrementsRelative
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelative.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelative",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    last_dose <- data@x[data@nObs]
    # Determine in which interval the `last_dose` is.
    assert_true(last_dose >= head(increments@intervals, 1))
    last_dose_interval <- findInterval(x = last_dose, vec = increments@intervals)
    (1 + increments@increments[last_dose_interval]) * last_dose
  }
)

## IncrementsRelativeDLT ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs so far.
#'
#' @aliases maxDose-IncrementsRelativeDLT
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLT.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLT",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    dlt_count <- sum(data@y)
    # Determine in which interval the `dlt_count` is.
    assert_true(dlt_count >= increments@intervals[1])
    dlt_count_interval <- findInterval(x = dlt_count, vec = increments@intervals)
    (1 + increments@increments[dlt_count_interval]) * data@x[data@nObs]
  }
)

## IncrementsRelativeDLTCurrent ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments determined by DLTs in the current cohort.
#'
#' @aliases maxDose-IncrementsRelativeDLTCurrent
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeDLTCurrent.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeDLTCurrent",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    last_dose <- data@x[data@nObs]

    # Determine how many DLTs have occurred in the last cohort.
    last_cohort <- data@cohort[data@nObs]
    last_cohort_indices <- which(data@cohort == last_cohort)
    dlt_count_lcohort <- sum(data@y[last_cohort_indices])

    # Determine in which interval the `dlt_count_lcohort` is.
    assert_true(dlt_count_lcohort >= increments@intervals[1])
    dlt_count_lcohort_int <- findInterval(x = dlt_count_lcohort, vec = increments@intervals)
    (1 + increments@increments[dlt_count_lcohort_int]) * last_dose
  }
)

## IncrementsRelativeParts ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   relative increments as well as part 1 and beginning of part 2.
#'
#' @aliases maxDose-IncrementsRelativeParts
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsRelativeParts.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsRelativeParts",
    data = "DataParts"
  ),
  definition = function(increments, data, ...) {
    all_in_part1 <- all(data@part == 1L)
    incrmnt <- if (all_in_part1) {
      part2_started <- data@nextPart == 2L
      if (part2_started) {
        any_dlt <- any(data@y == 1L)
        if (any_dlt) {
          increments@dlt_start
        } else if (increments@clean_start <= 0L) {
          increments@clean_start
        }
      } else {
        1L
      }
    }

    if (is.null(incrmnt)) {
      callNextMethod(increments, data, ...)
    } else {
      max_dose_lev_part1 <- match_within_tolerance(max(data@x), data@part1Ladder)
      new_max_dose_level <- max_dose_lev_part1 + incrmnt
      assert_true(new_max_dose_level >= 0L)
      assert_true(new_max_dose_level <= length(data@part1Ladder))
      data@part1Ladder[new_max_dose_level]
    }
  }
)

## IncrementsDoseLevels ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   the number of dose grid levels. That is, the max dose is determined as
#'   the one which level is equal to: base dose level + level increment.
#'   The base dose level is the level of the last dose in grid or the level
#'   of the maximum dose applied, which is defined in `increments` object.
#'   Find out more in [`IncrementsDoseLevels`].
#'
#' @aliases maxDose-IncrementsDoseLevels
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsDoseLevels.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsDoseLevels",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Determine what is the basis level for increment,
    # i.e. the last dose or the max dose applied.
    basis_dose_level <- ifelse(
      increments@basis_level == "last", data@xLevel[data@nObs], max(data@xLevel)
    )
    max_dose_level <- min(basis_dose_level + increments@levels, data@nGrid)
    data@doseGrid[max_dose_level]
  }
)

## IncrementsHSRBeta ----

#' @describeIn maxDose determine the maximum possible next dose for escalation.
#'
#' @aliases maxDose-IncrementsHSRBeta
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsHSRBeta.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsHSRBeta",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    # Summary of observed data per dose level.
    y <- factor(data@y, levels = c("0", "1"))
    dlt_tab <- table(y, data@x)

    # Ignore placebo if applied.
    if (data@placebo == TRUE & min(data@x) == data@doseGrid[1]) {
      dlt_tab <- dlt_tab[, -1]
    }

    # Extract dose names as these get lost if only one dose available.
    non_plcb_doses <- unique(sort(as.numeric(colnames(dlt_tab))))

    # Toxicity probability per dose level.
    x <- dlt_tab[2, ]
    n <- apply(dlt_tab, 2, sum)
    tox_prob <- pbeta(
      increments@target,
      x + increments@a,
      n - x + increments@b,
      lower.tail = FALSE
    )

    # Return the min toxic dose level or maximum dose level if no dose is toxic,
    # while ignoring placebo.
    dose_tox <- if (sum(tox_prob > increments@prob) > 0) {
      min(non_plcb_doses[which(tox_prob > increments@prob)])
    } else {
      # Add small value to max dose, so that the max dose is always smaller.
      max(data@doseGrid) + 0.01
    }

    # Determine the next maximum possible dose.
    # In case that the first active dose is above probability threshold,
    # the first active dose is reported as maximum. I.e. in case that placebo is used,
    # the second dose is reported. Please note that this rule should be used together
    # with the hard safety stopping rule to avoid inconsistent results.
    max(data@doseGrid[data@doseGrid < dose_tox], data@doseGrid[data@placebo + 1])
  }
)

## IncrementsMin ----

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsMin.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "Data"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(increments@increments_list, maxDose, data = data, ...)
    min(individual_results)
  }
)

#' @describeIn maxDose determine the maximum possible next dose based on
#'   multiple increment rules, taking the minimum across individual increments.
#'
#' @aliases maxDose-IncrementsMin
#'
#' @export
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsMin",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    individual_results <- sapply(increments@increments_list, maxDose, data = data, ...)
    min(individual_results)
  }
)

## IncrementsOrdinal ----

#' @describeIn maxDose determine the maximum possible next dose in an ordinal
#' CRM trial
#'
#' @aliases maxDose-IncrementsOrdinal
#'
#' @export
#' @example examples/Rules-method-maxDose-IncrementsOrdinal.R
#'
setMethod(
  f = "maxDose",
  signature = signature(
    increments = "IncrementsOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(increments, data, ...) {
    maxDose(
      increments = increments@rule,
      data = h_convert_ordinal_data(
        data,
        increments@grade,
        ...
      )
    )
  }
)

# nolint start

## ============================================================

## --------------------------------------------------
## "AND" combination of stopping rules
## --------------------------------------------------

##' The method combining two atomic stopping rules
##'
##' @param e1 First \code{\linkS4class{Stopping}} object
##' @param e2 Second \code{\linkS4class{Stopping}} object
##' @return The \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stopping-stopping.R
##' @keywords methods
setMethod("&",
  signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      StoppingAll(list(e1, e2))
    }
)

##' The method combining a stopping list and an atomic
##'
##' @param e1 \code{\linkS4class{StoppingAll}} object
##' @param e2 \code{\linkS4class{Stopping}} object
##' @return The modified \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stoppingAll-stopping.R
##' @keywords methods
setMethod("&",
  signature(
    e1 = "StoppingAll",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      e1@stop_list <- c(
        e1@stop_list,
        e2
      )
      return(e1)
    }
)

##' The method combining an atomic and a stopping list
##'
##' @param e1 \code{\linkS4class{Stopping}} object
##' @param e2 \code{\linkS4class{StoppingAll}} object
##' @return The modified \code{\linkS4class{StoppingAll}} object
##'
##' @example examples/Rules-method-and-stopping-stoppingAll.R
##' @keywords methods
setMethod("&",
  signature(
    e1 = "Stopping",
    e2 = "StoppingAll"
  ),
  def =
    function(e1, e2) {
      e2@stop_list <- c(
        e1,
        e2@stop_list
      )
      return(e2)
    }
)

## --------------------------------------------------
## "OR" combination of stopping rules
## --------------------------------------------------

##' The method combining two atomic stopping rules
##'
##' @param e1 First \code{\linkS4class{Stopping}} object
##' @param e2 Second \code{\linkS4class{Stopping}} object
##' @return The \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,Stopping,Stopping-method
##' @name or-Stopping-Stopping
##' @example examples/Rules-method-or-stopping-stopping.R
##' @keywords methods
setMethod("|",
  signature(
    e1 = "Stopping",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      StoppingAny(list(e1, e2))
    }
)

##' The method combining a stopping list and an atomic
##'
##' @param e1 \code{\linkS4class{StoppingAny}} object
##' @param e2 \code{\linkS4class{Stopping}} object
##' @return The modified \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,StoppingAny,Stopping-method
##' @name or-Stopping-StoppingAny
##' @example examples/Rules-method-or-stoppingAny-stopping.R
##' @keywords methods
setMethod("|",
  signature(
    e1 = "StoppingAny",
    e2 = "Stopping"
  ),
  def =
    function(e1, e2) {
      e1@stop_list <- c(
        e1@stop_list,
        e2
      )
      return(e1)
    }
)

##' The method combining an atomic and a stopping list
##'
##' @param e1 \code{\linkS4class{Stopping}} object
##' @param e2 \code{\linkS4class{StoppingAny}} object
##' @return The modified \code{\linkS4class{StoppingAny}} object
##'
##' @aliases |,Stopping,StoppingAny-method
##' @name or-StoppingAny-Stopping
##' @example examples/Rules-method-or-stopping-stoppingAny.R
##' @keywords methods
setMethod("|",
  signature(
    e1 = "Stopping",
    e2 = "StoppingAny"
  ),
  def =
    function(e1, e2) {
      e2@stop_list <- c(
        e1,
        e2@stop_list
      )
      return(e2)
    }
)

# nolint end

# Stopping ----

## generic ----

#' Stop the trial?
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function returns whether to stop the trial.
#'
#' @param stopping (`Stopping`)\cr the rule for stopping the trial.
#' @param dose the recommended next best dose.
#' @param samples (`Samples`)\cr the mcmc samples.
#' @param model (`GeneralModel`)\cr the model.
#' @param data (`Data`)\cr input data.
#' @param ... additional arguments without method dispatch.
#'
#' @return logical value: `TRUE` if the trial can be stopped, `FALSE`
#' otherwise. It should have an attribute `message` which gives the reason
#' for the decision.
#'
#' @export
#' @example examples/Rules-method-CombiningStoppingRulesAndOr.R
setGeneric(
  name = "stopTrial",
  def = function(stopping, dose, samples, model, data, ...) {
    standardGeneric("stopTrial")
  },
  valueClass = "logical"
)

## StoppingMissingDose ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingMissingDose
#' @example examples/Rules-method-stopTrial-StoppingMissingDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMissingDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    do_stop <- is.na(dose) || (data@placebo && dose == min(data@doseGrid))

    msg <- paste(
      "Next dose is",
      ifelse(
        do_stop,
        paste(
          ifelse(
            data@placebo && dose == min(data@doseGrid),
            "placebo dose",
            "NA"
          ),
          ", i.e., no active dose is safe enough according to the NextBest rule."
        ),
        "available at the dose grid."
      )
    )

    structure(do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

# nolint start

## --------------------------------------------------
## Stopping based on multiple stopping rules
## --------------------------------------------------

##' @describeIn stopTrial Stop based on multiple stopping rules
##' @example examples/Rules-method-stopTrial-StoppingList.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingList",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## evaluate the individual stopping rules
      ## in the list
      individualResults <-
        if (missing(samples)) {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            model = model,
            data = data,
            ...
          )
        } else {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            samples = samples,
            model = model,
            data = data,
            ...
          )
        }

      ## summarize to obtain overall result
      overallResult <- stopping@summary(as.logical(individualResults))

      ## retrieve individual text messages,
      ## but let them in the list structure
      overallText <- lapply(individualResults, attr, "message")

      return(structure(overallResult,
        message = overallText,
        individual = individualResults
      ))
    }
)

## --------------------------------------------------
## Stopping based on fulfillment of all multiple stopping rules
## --------------------------------------------------

##' @describeIn stopTrial Stop based on fulfillment of all multiple stopping
##' rules
##'
##' @example examples/Rules-method-stopTrial-StoppingAll.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingAll",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## evaluate the individual stopping rules
      ## in the list
      individualResults <-
        if (missing(samples)) {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            model = model,
            data = data,
            ...
          )
        } else {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            samples = samples,
            model = model,
            data = data,
            ...
          )
        }

      ## summarize to obtain overall result
      overallResult <- all(as.logical(individualResults))

      ## retrieve individual text messages,
      ## but let them in the list structure
      overallText <- lapply(individualResults, attr, "message")

      return(structure(overallResult,
        message = overallText,
        individual = individualResults,
        report_label = stopping@report_label
      ))
    }
)


## --------------------------------------------------
## Stopping based on fulfillment of any stopping rule
## --------------------------------------------------

##' @describeIn stopTrial Stop based on fulfillment of any stopping rule
##'
##' @example examples/Rules-method-stopTrial-StoppingAny.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingAny",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## evaluate the individual stopping rules
      ## in the list
      individualResults <-
        if (missing(samples)) {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            model = model,
            data = data,
            ...
          )
        } else {
          lapply(stopping@stop_list,
            stopTrial,
            dose = dose,
            samples = samples,
            model = model,
            data = data,
            ...
          )
        }

      ## summarize to obtain overall result
      overallResult <- any(as.logical(individualResults))

      ## retrieve individual text messages,
      ## but let them in the list structure
      overallText <- lapply(individualResults, attr, "message")

      return(structure(overallResult,
        message = overallText,
        individual = individualResults,
        report_label = stopping@report_label
      ))
    }
)




## --------------------------------------------------
## Stopping based on number of cohorts near to next best dose
## --------------------------------------------------

##' @describeIn stopTrial Stop based on number of cohorts near to next best dose
##'
##' @example examples/Rules-method-stopTrial-StoppingCohortsNearDose.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingCohortsNearDose",
      dose = "numeric",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## determine the range where the cohorts must lie in
      lower <- (100 - stopping@percentage) / 100 * dose
      upper <- (100 + stopping@percentage) / 100 * dose

      ## which patients lie there?
      indexPatients <- which((data@x >= lower) & (data@x <= upper))

      ## how many cohorts?
      nCohorts <- length(unique(data@cohort[indexPatients]))

      ## so can we stop?
      doStop <- nCohorts >= stopping@nCohorts

      ## generate message
      text <- paste(nCohorts,
        " cohorts lie within ",
        stopping@percentage,
        "% of the next best dose ",
        dose,
        ". This ",
        ifelse(doStop, "reached", "is below"),
        " the required ",
        stopping@nCohorts,
        " cohorts",
        sep = ""
      )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)


## -------------------------------------------------------------
## Stopping based on number of patients near to next best dose
## -------------------------------------------------------------

##' @describeIn stopTrial Stop based on number of patients near to next best
##' dose
##'
##' @example examples/Rules-method-stopTrial-StoppingPatientsNearDose.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingPatientsNearDose",
      dose = "numeric",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## determine the range where the cohorts must lie in
      lower <- (100 - stopping@percentage) / 100 * dose
      upper <- (100 + stopping@percentage) / 100 * dose

      ## how many patients lie there?
      nPatients <- ifelse(
        is.na(dose),
        0,
        sum((data@x >= lower) & (data@x <= upper))
      )

      ## so can we stop?
      doStop <- nPatients >= stopping@nPatients

      ## generate message
      text <- paste(nPatients,
        " patients lie within ",
        stopping@percentage,
        "% of the next best dose ",
        dose,
        ". This ",
        ifelse(doStop, "reached", "is below"),
        " the required ",
        stopping@nPatients,
        " patients",
        sep = ""
      )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## --------------------------------------------------
## Stopping based on minimum number of cohorts
## --------------------------------------------------

##' @describeIn stopTrial Stop based on minimum number of cohorts
##'
##' @example examples/Rules-method-stopTrial-StoppingMinCohorts.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMinCohorts",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## determine number of cohorts
      nCohorts <- length(unique(data@cohort))

      ## so can we stop?
      doStop <- nCohorts >= stopping@nCohorts

      ## generate message
      text <-
        paste(
          "Number of cohorts is",
          nCohorts,
          "and thus",
          ifelse(doStop, "reached", "below"),
          "the prespecified minimum number",
          stopping@nCohorts
        )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## --------------------------------------------------
## Stopping based on minimum number of patients
## --------------------------------------------------

##' @describeIn stopTrial Stop based on minimum number of patients
##'
##' @example examples/Rules-method-stopTrial-StoppingMinPatients.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMinPatients",
      dose = "ANY",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## so can we stop?
      doStop <- data@nObs >= stopping@nPatients

      ## generate message
      text <-
        paste(
          "Number of patients is",
          data@nObs,
          "and thus",
          ifelse(doStop, "reached", "below"),
          "the prespecified minimum number",
          stopping@nPatients
        )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

# nolint end

## StoppingTargetProb ----

#' @describeIn stopTrial Stop based on probability of target tox interval
#'
#' @aliases stopTrial-StoppingTargetProb
#' @example examples/Rules-method-stopTrial-StoppingTargetProb.R
setMethod(
  f = "stopTrial",
  signature =
    signature(
      stopping = "StoppingTargetProb",
      dose = "numeric",
      samples = "Samples",
      model = "GeneralModel",
      data = "ANY"
    ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute probability to be in target interval.
    prob_target <- ifelse(
      is.na(dose),
      0,
      mean(
        prob(dose = dose, model, samples, ...) >= stopping@target[1] &
          prob(dose = dose, model, samples, ...) <= stopping@target[2]
      )
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target toxicity is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

# nolint start

## --------------------------------------------------
## Stopping based on MTD distribution
## --------------------------------------------------

##' @describeIn stopTrial Stop based on MTD distribution
##'
##' @example examples/Rules-method-stopTrial-StoppingMTDdistribution.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMTDdistribution",
      dose = "numeric",
      samples = "Samples",
      model = "GeneralModel",
      data = "ANY"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      ## First, generate the MTD samples.

      ## add prior data and samples to the
      ## function environment so that they
      ## can be used.
      mtdSamples <- dose(
        x = stopping@target,
        model,
        samples,
        ...
      )

      ## what is the absolute threshold?
      absThresh <- stopping@thresh * dose

      ## what is the probability to be above this dose?
      prob <- ifelse(
        is.na(absThresh),
        0,
        mean(mtdSamples > absThresh)
      )

      ## so can we stop?
      doStop <- prob >= stopping@prob

      ## generate message
      text <-
        paste(
          "Probability of MTD above",
          round(stopping@thresh * 100),
          "% of current dose",
          dose,
          "is",
          round(prob * 100),
          "% and thus",
          ifelse(doStop, "greater than or equal to", "strictly less than"),
          "the required",
          round(stopping@prob * 100),
          "%"
        )

      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

# nolint end

## StoppingMTDCV ----

#' @rdname stopTrial
#'
#' @description Stopping rule based precision of the MTD estimation.
#'   The trial is stopped, when the MTD can be estimated with sufficient precision.
#'   The criteria is based on the robust coefficient of variation (CV) calculated
#'   from the posterior distribution.
#'   The robust CV is defined `mad(MTD) / median(MTD)`, where `mad` is the median
#'   absolute deviation.
#'
#' @aliases stopTrial-StoppingMTDCV
#' @example examples/Rules-method-stopTrial-StoppingMTDCV.R
#' @export
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingMTDCV",
    dose = "numeric",
    samples = "Samples",
    model = "GeneralModel",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    mtd_samples <- dose(
      x = stopping@target,
      model,
      samples,
      ...
    )
    # CV of MTD expressed as percentage, derived based on MTD posterior samples.
    mtd_cv <- (mad(mtd_samples) / median(mtd_samples)) * 100
    do_stop <- mtd_cv <= stopping@thresh_cv

    msg <- paste(
      "CV of MTD is",
      round(mtd_cv),
      "% and thus",
      ifelse(do_stop, "below", "above"),
      "the required precision threshold of",
      round(stopping@thresh_cv),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)


## StoppingLowestDoseHSRBeta ----

#' @rdname stopTrial
#'
#' @description Stopping based based on the lowest non placebo dose. The trial is
#'  stopped when the lowest non placebo dose meets the Hard
#'  Safety Rule, i.e. it is deemed to be overly toxic. Stopping is based on the
#'  observed data at the lowest dose level using a Bin-Beta model
#'  based on DLT probability.
#'
#' @aliases stopTrial-StoppingLowestDoseHSRBeta
#' @example examples/Rules-method-stopTrial-StoppingLowestDoseHSRBeta.R
#' @export
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingLowestDoseHSRBeta",
    dose = "numeric",
    samples = "Samples"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Actual number of patients at first active dose.
    n <- sum(data@x == data@doseGrid[data@placebo + 1])

    # Determine toxicity probability of the first active dose.
    tox_prob_first_dose <-
      if (n > 0) {
        x <- sum(data@y[which(data@x == data@doseGrid[data@placebo + 1])])
        pbeta(stopping@target, x + stopping@a, n - x + stopping@b, lower.tail = FALSE)
      } else {
        0
      }

    do_stop <- tox_prob_first_dose > stopping@prob

    # generate message
    msg <- if (n == 0) {
      "Lowest active dose not tested, stopping rule not applied."
    } else {
      paste(
        "Probability that the lowest active dose of ",
        data@doseGrid[data@placebo + 1],
        " being toxic based on posterior Beta distribution using a Beta(",
        stopping@a, ",", stopping@b, ") prior is ",
        round(tox_prob_first_dose * 100),
        "% and thus ",
        ifelse(do_stop, "above", "below"),
        " the required ",
        round(stopping@prob * 100),
        "% threshold.",
        sep = ""
      )
    }

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## StoppingTargetBiomarker ----

#' @describeIn stopTrial Stop based on probability of targeting biomarker
#'
#' @aliases stopTrial-StoppingTargetBiomarker
#' @example examples/Rules-method-stopTrial-StoppingTargetBiomarker.R
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTargetBiomarker",
    dose = "numeric",
    samples = "Samples",
    model = "DualEndpoint",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Compute the target biomarker prob at this dose.
    # Get the biomarker level samples at the dose grid points.
    biom_level_samples <- biomarker(xLevel = seq_len(data@nGrid), model, samples, ...)

    # If target is relative to maximum.
    if (stopping@is_relative) {
      # If there is an 'Emax' parameter, target biomarker level will
      # be relative to 'Emax', otherwise will be relative to the
      # maximum biomarker level achieved in the given dose range.
      if ("Emax" %in% names(samples)) {
        # For each sample, look which dose is maximizing the
        # simultaneous probability to be in the target biomarker
        # range and below overdose toxicity.
        prob_target <- numeric(ncol(biom_level_samples))
        prob_target <- sapply(
          seq(1, ncol(biom_level_samples)),
          function(x) {
            sum(biom_level_samples[, x] >= stopping@target[1] * samples@data$Emax &
              biom_level_samples[, x] <= stopping@target[2] * samples@data$Emax) /
              nrow(biom_level_samples)
          }
        )
      } else {
        # For each sample, look which was the minimum dose giving
        # relative target level.
        targetIndex <- apply(
          biom_level_samples, 1L,
          function(x) {
            rnx <- range(x)
            min(which(
              (x >= stopping@target[1] * diff(rnx) + rnx[1]) &
                (x <= stopping@target[2] * diff(rnx) + rnx[1] + 1e-10)
            ))
          }
        )
        prob_target <- numeric(ncol(biom_level_samples))
        tab <- table(targetIndex)
        prob_target[as.numeric(names(tab))] <- tab
        prob_target <- prob_target / nrow(biom_level_samples)
      }
    } else {
      # Otherwise the target is absolute.
      # For each sample, look which dose is maximizing the
      # simultaneous probability to be in the target biomarker
      # range and below overdose toxicity.
      prob_target <- numeric(ncol(biom_level_samples))
      prob_target <- sapply(
        seq(1, ncol(biom_level_samples)),
        function(x) {
          sum(biom_level_samples[, x] >= stopping@target[1] & biom_level_samples[, x] <= stopping@target[2]) /
            nrow(biom_level_samples)
        }
      )
    }

    prob_target <- ifelse(
      is.na(dose),
      0,
      prob_target[which(data@doseGrid == dose)]
    )

    do_stop <- prob_target >= stopping@prob

    msg <- paste(
      "Probability for target biomarker is",
      round(prob_target * 100),
      "% for dose",
      dose,
      "and thus",
      ifelse(do_stop, "above", "below"),
      "the required",
      round(stopping@prob * 100),
      "%"
    )

    structure(
      do_stop,
      message = msg,
      report_label = stopping@report_label
    )
  }
)

## StoppingSpecificDose ----

#' @describeIn stopTrial if Stopping rule is met for specific dose of the planned
#' dose grid and not just for the default next best dose.
#'
#' @aliases stopTrial-StoppingSpecificDose
#'
#' @export
#' @example examples/Rules-method-stopTrial-StoppingSpecificDose.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingSpecificDose",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "Data"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    # Specific dose must be a part of the dose grid.
    assert_subset(x = stopping@dose@.Data, choices = data@doseGrid)

    # Evaluate the original (wrapped) stopping rule at the specific dose.
    result <- stopTrial(
      stopping = stopping@rule,
      dose = stopping@dose@.Data,
      samples = samples,
      model = model,
      data = data,
      ...
    )
    # Correct the text message from the original stopping rule.
    attr(result, "message") <- gsub(
      pattern = "next best",
      replacement = "specific",
      x = attr(result, "message"),
      ignore.case = TRUE
    )

    attr(result, "report_label") <- stopping@report_label

    result
  }
)

# nolint start

## --------------------------------------------------
## Stopping when the highest dose is reached
## --------------------------------------------------

##' @describeIn stopTrial Stop when the highest dose is reached
##'
##' @example examples/Rules-method-stopTrial-StoppingHighestDose.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingHighestDose",
      dose = "numeric",
      samples = "ANY",
      model = "ANY",
      data = "Data"
    ),
  def =
    function(stopping, dose, samples, model, data, ...) {
      isHighestDose <- ifelse(
        is.na(dose),
        FALSE,
        (dose == data@doseGrid[data@nGrid])
      )
      return(structure(isHighestDose,
        message =
          paste(
            "Next best dose is", dose, "and thus",
            ifelse(isHighestDose, "the",
              "not the"
            ),
            "highest dose"
          ),
        report_label = stopping@report_label
      ))
    }
)

## StoppingOrdinal ----

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stopTrial(
      stopping = stopping@rule,
      dose = dose,
      samples = h_convert_ordinal_samples(samples, stopping@grade),
      model = h_convert_ordinal_model(model, stopping@grade),
      data = h_convert_ordinal_data(data, stopping@grade),
      ...
    )
  }
)

#' @describeIn stopTrial Stop based on value returned by next best dose.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @aliases stopTrial-StoppingOrdinal
#' @example examples/Rules-method-stopTrial-StoppingOrdinal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingOrdinal",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    stop(
      paste0(
        "StoppingOrdinal objects can only be used with LogisticLogNormalOrdinal ",
        "models and DataOrdinal data objects. In this case, the model is a '",
        class(model),
        "' object and the data is in a ",
        class(data),
        " object."
      )
    )
  }
)

## StoppingExternal ----

#' @describeIn stopTrial Stop based on an external flag.
#'
#' @description `r lifecycle::badge("experimental")`
#' @param external (`flag`)\cr whether to stop based on the external
#'   result or not.
#'
#' @aliases stopTrial-StoppingExternal
#' @example examples/Rules-method-stopTrial-StoppingExternal.R
#'
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingExternal",
    dose = "numeric",
    samples = "ANY",
    model = "ANY",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, external, ...) {
    assert_flag(external)

    msg <- paste(
      "Based on external result",
      ifelse(external, "stop", "continue")
    )

    structure(
      external,
      message = msg,
      report_label = stopping@report_label
    )
  }
)


## ============================================================

## --------------------------------------------------
## "MAX" combination of cohort size rules
## --------------------------------------------------

##' "MAX" combination of cohort size rules
##'
##' This function combines cohort size rules by taking
##' the maximum of all sizes.
##'
##' @param \dots Objects of class \code{\linkS4class{CohortSize}}
##' @return the combination as an object of class
##' \code{\linkS4class{CohortSizeMax}}
##'
##' @seealso \code{\link{minSize}}
##' @export
##' @keywords methods
setGeneric("maxSize",
  def =
    function(...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("maxSize")
    },
  valueClass = "CohortSizeMax"
)

##' @describeIn maxSize The method combining cohort size rules by taking maximum
##' @example examples/Rules-method-maxSize.R
setMethod("maxSize",
  "CohortSize",
  def =
    function(...) {
      CohortSizeMax(list(...))
    }
)

## --------------------------------------------------
## "MIN" combination of cohort size rules
## --------------------------------------------------

##' "MIN" combination of cohort size rules
##'
##' This function combines cohort size rules by taking
##' the minimum of all sizes.
##'
##' @param \dots Objects of class \code{\linkS4class{CohortSize}}
##' @return the combination as an object of class
##' \code{\linkS4class{CohortSizeMin}}
##'
##' @seealso \code{\link{maxSize}}
##' @export
##' @keywords methods
setGeneric("minSize",
  def =
    function(...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("minSize")
    },
  valueClass = "CohortSizeMin"
)

##' @describeIn minSize The method combining cohort size rules by taking minimum
##' @example examples/Rules-method-minSize.R
setMethod("minSize",
  "CohortSize",
  def =
    function(...) {
      CohortSizeMin(list(...))
    }
)

# size ----

## CohortSizeRange ----

#' @describeIn size Determines the size of the next cohort based on the range
#'   into which the next dose falls into.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeRange
#' @example examples/Rules-method-size-CohortSizeRange.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeRange"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine in which interval the next dose is.
    interval <- findInterval(x = dose, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## CohortSizeDLT ----

#' @describeIn size Determines the size of the next cohort based on the number
#'   of DLTs so far.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeDLT
#' @example examples/Rules-method-size-CohortSizeDLT.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeDLT"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Determine how many DLTs have occurred so far.
    dlt_happened <- sum(data@y)

    # Determine in which interval this is.
    interval <- findInterval(x = dlt_happened, vec = object@intervals)
    object@cohort_size[interval]
  }
)

## CohortSizeMax ----

#' @describeIn size Determines the size of the next cohort based on maximum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMax
#' @example examples/Rules-method-size-CohortSizeMax.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMax"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    max(individual_results)
  }
)

## CohortSizeMin ----

#' @describeIn size Determines the size of the next cohort based on minimum of
#'   multiple cohort size rules.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeMin
#' @example examples/Rules-method-size-CohortSizeMin.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeMin"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    }
    assert_class(data, "Data")

    # Evaluate the individual cohort size rules in the list.
    individual_results <- sapply(
      object@cohort_sizes,
      size,
      dose = dose,
      data = data
    )
    # The overall result.
    min(individual_results)
  }
)

## CohortSizeConst ----

#' @describeIn size Constant cohort size.
#'
#' @param dose the next dose.
#' @param ... not used.
#'
#' @aliases size-CohortSizeConst
#' @example examples/Rules-method-size-CohortSizeConst.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeConst"
  ),
  definition = function(object, dose, ...) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      0L
    } else {
      object@size
    }
  }
)

## CohortSizeParts ----

#' @describeIn size Determines the size of the next cohort based on the parts.
#'
#' @param dose the next dose.
#' @param data the data input, an object of class [`Data`].
#'
#' @aliases size-CohortSizeParts
#' @example examples/Rules-method-size-CohortSizeParts.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeParts"
  ),
  definition = function(object, dose, data) {
    # If the recommended next dose is NA, don't check it and return 0.
    if (is.na(dose)) {
      return(0L)
    } else {
      assert_class(data, "DataParts")
      object@cohort_sizes[data@nextPart]
    }
  }
)

## CohortSizeOrdinal ----

#' @describeIn size Determines the size of the next cohort in a ordinal CRM trial.
#'
#' @param  dose (`numeric`) the next dose.
#' @param data the data input, an object of class [`DataOrdinal`].
#'
#' @aliases size-CohortSizeOrdinal
#' @example examples/Rules-method-size-CohortSizeOrdinal.R
#'
setMethod(
  f = "size",
  signature = signature(
    object = "CohortSizeOrdinal"
  ),
  definition = function(object, dose, data, ...) {
    # Validate
    assert_numeric(dose, len = 1, lower = 0)
    assert_class(data, "DataOrdinal")
    # Execute

    size(
      object@rule,
      dose = dose,
      data = h_convert_ordinal_data(data, object@grade),
      ...
    )
  }
)

## ------------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on 'StoppingTDCIRatio' class when
##' reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (TDtargetEndOfTrial). This is a stopping rule which incorporate only
##' DLE responses and DLE samples are given
##'
##' @example examples/Rules-method-stopTrialCITDsamples.R
##'
##' @export
##' @keywords methods
setMethod(
  f = "stopTrial",
  signature = signature(
    stopping = "StoppingTDCIRatio",
    dose = "ANY",
    samples = "Samples",
    model = "ModelTox",
    data = "ANY"
  ),
  definition = function(stopping, dose, samples, model, data, ...) {
    assert_probability(stopping@prob_target)

    dose_target_samples <- dose(
      x = stopping@prob_target,
      model = model,
      samples = samples,
      ...
    )
    # 95% credibility interval.
    dose_target_ci <- quantile(dose_target_samples, probs = c(0.025, 0.975))
    dose_target_ci_ratio <- dose_target_ci[[2]] / dose_target_ci[[1]]

    do_stop <- dose_target_ci_ratio <= stopping@target_ratio
    text <- paste0(
      "95% CI is (",
      paste(dose_target_ci, collapse = ", "),
      "), Ratio = ",
      round(dose_target_ci_ratio, 4),
      " is ",
      ifelse(do_stop, "less than or equal to ", "greater than "),
      "target_ratio = ", stopping@target_ratio
    )
    structure(do_stop,
      message = text,
      report_label = stopping@report_label
    )
  }
)

## ----------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on 'StoppingTDCIRatio' class
##' when reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (TDtargetEndOfTrial). This is a stopping rule which incorporate only
##' DLE responses and no DLE samples are involved
##' @example examples/Rules-method-stopTrialCITD.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingTDCIRatio",
      dose = "ANY",
      samples = "missing",
      model = "ModelTox",
      data = "ANY"
    ),
  def =
    function(stopping, dose, model, data, ...) {
      assert_probability(stopping@prob_target)

      prob_target <- stopping@prob_target
      dose_target_samples <- dose(x = prob_target, model = model, ...)
      ## Find the variance of the log of the dose_target_samples(eta)
      M1 <- matrix(c(-1 / (model@phi2), -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2), 1, 2)
      M2 <- model@Pcov
      varEta <- as.vector(M1 %*% M2 %*% t(M1))

      ## Find the upper and lower limit of the 95% credibility interval
      CI <- exp(log(dose_target_samples) + c(-1, 1) * 1.96 * sqrt(varEta))
      ratio <- CI[2] / CI[1]

      ## so can we stop?
      doStop <- ratio <= stopping@target_ratio
      ## generate message
      text <- paste(
        "95% CI is (", round(CI[1], 4), ",", round(CI[2], 4), "), Ratio =", round(ratio, 4), "is ", ifelse(doStop, "is less than or equal to", "greater than"),
        "target_ratio =", stopping@target_ratio
      )
      ## return both
      return(structure(
        doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## --------------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## ------------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (the minimum of Gstar and TDtargetEndOfTrial). This is a stopping rule which
##' incorporate DLE and efficacy responses and DLE and efficacy samples are also used.
##'
##' @param TDderive the function which derives from the input, a vector of the posterior samples called
##' \code{TDsamples} of the dose
##' which has the probability of the occurrence of DLE equals to either the targetDuringTrial or
##' targetEndOfTrial, the final next best TDtargetDuringTrial (the dose with probability of the
##' occurrence of DLE equals to the targetDuringTrial)and TDtargetEndOfTrial estimate.
##' @param Effmodel the efficacy model of \code{\linkS4class{ModelEff}} class object
##' @param Effsamples the efficacy samples of \code{\linkS4class{Samples}} class object
##' @param Gstarderive the function which derives from the input, a vector of the posterior Gstar (the dose
##' which gives the maximum gain value) samples
##' called \code{Gstarsamples}, the final next best Gstar estimate.
##'
##' @example examples/Rules-method-stopTrialCIMaxGainSamples.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMaxGainCIRatio",
      dose = "ANY",
      samples = "Samples",
      model = "ModelTox",
      data = "DataDual"
    ),
  def =
    function(stopping, dose, samples, model, data, TDderive, Effmodel, Effsamples, Gstarderive, ...) {
      prob_target <- stopping@prob_target

      ## checks
      assert_probability(prob_target)
      stopifnot(is(Effmodel, "ModelEff"))
      stopifnot(is(Effsamples, "Samples"))
      stopifnot(is.function(TDderive))
      stopifnot(is.function(Gstarderive))

      ## find the TDtarget End of Trial samples
      TDtargetEndOfTrialSamples <- dose(
        x = prob_target,
        model = model,
        samples = samples,
        ...
      )
      ## Find the TDtarget End of trial estimate
      TDtargetEndOfTrialEstimate <- TDderive(TDtargetEndOfTrialSamples)

      ## Find the gain value samples then the GstarSamples
      points <- data@doseGrid

      GainSamples <- matrix(
        nrow = size(samples),
        ncol = length(points)
      )

      ## evaluate the probs, for all gain samples.
      for (i in seq_along(points))
      {
        ## Now we want to evaluate for the
        ## following dose:
        GainSamples[, i] <- gain(
          dose = points[i],
          model,
          samples,
          Effmodel,
          Effsamples,
          ...
        )
      }

      ## Find the maximum gain value samples
      MaxGainSamples <- apply(GainSamples, 1, max)

      ## Obtain Gstar samples, samples for the dose level which gives the maximum gain value
      IndexG <- apply(GainSamples, 1, which.max)
      GstarSamples <- data@doseGrid[IndexG]

      ## Find the Gstar estimate

      Gstar <- Gstarderive(GstarSamples)
      ## Find the 95% credibility interval of Gstar and its ratio of the upper to the lower limit
      CIGstar <- quantile(GstarSamples, probs = c(0.025, 0.975))
      ratioGstar <- as.numeric(CIGstar[2] / CIGstar[1])

      ## Find the 95% credibility interval of TDtargetEndOfTrial and its ratio of the upper to the lower limit
      CITDEOT <- quantile(TDtargetEndOfTrialSamples, probs = c(0.025, 0.975))
      ratioTDEOT <- as.numeric(CITDEOT[2] / CITDEOT[1])

      ## Find which is smaller (TDtargetEndOfTrialEstimate or Gstar)

      if (TDtargetEndOfTrialEstimate <= Gstar) {
        ## Find the upper and lower limit of the 95% credibility interval and its ratio of the smaller
        CI <- CITDEOT
        ratio <- ratioTDEOT
        chooseTD <- TRUE
      } else {
        CI <- CIGstar
        ratio <- ratioGstar
        chooseTD <- FALSE
      }

      ## so can we stop?
      doStop <- ratio <= stopping@target_ratio
      ## generate message
      text1 <- paste(
        "Gstar estimate is", round(Gstar, 4), "with 95% CI (", round(CIGstar[1], 4), ",", round(CIGstar[2], 4),
        ") and its ratio =",
        round(ratioGstar, 4)
      )
      text2 <- paste(
        "TDtargetEndOfTrial estimate is ", round(TDtargetEndOfTrialEstimate, 4),
        "with 95% CI (", round(CITDEOT[1], 4), ",", round(CITDEOT[2], 4), ") and its ratio=",
        round(ratioTDEOT, 4)
      )
      text3 <- paste(
        ifelse(chooseTD, "TDtargetEndOfTrial estimate", "Gstar estimate"), "is smaller with ratio =",
        round(ratio, 4), " which is ", ifelse(doStop, "is less than or equal to", "greater than"),
        "target_ratio =", stopping@target_ratio
      )
      text <- c(text1, text2, text3)
      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)

## -----------------------------------------------------------------------------------------------
## Stopping based on a target ratio of the upper to the lower 95% credibility interval
## --------------------------------------------------------------------------------------------
##' @describeIn stopTrial Stop based on reaching the target ratio of the upper to the lower 95% credibility
##' interval of the estimate (the minimum of Gstar and TDtargetEndOfTrial). This is a stopping rule which
##' incorporate DLE and efficacy responses without DLE and efficacy samples involved.
##' @example examples/Rules-method-stopTrialCIMaxGain.R
setMethod("stopTrial",
  signature =
    signature(
      stopping = "StoppingMaxGainCIRatio",
      dose = "ANY",
      samples = "missing",
      model = "ModelTox",
      data = "DataDual"
    ),
  def =
    function(stopping, dose, model, data, Effmodel, ...) {
      prob_target <- stopping@prob_target

      ## checks
      assert_probability(prob_target)
      stopifnot(is(Effmodel, "ModelEff"))


      ## find the TDtarget End of Trial
      TDtargetEndOfTrial <- dose(
        x = prob_target,
        model = model,
        ...
      )

      ## Find the dose with maximum gain value
      Gainfun <- function(DOSE) {
        -gain(DOSE, model_dle = model, model_eff = Effmodel, ...)
      }

      # if(data@placebo) {
      # n <- length(data@doseGrid)
      # LowestDose <- sort(data@doseGrid)[2]} else {
      LowestDose <- min(data@doseGrid)
      # }

      Gstar <- (optim(LowestDose, Gainfun, method = "L-BFGS-B", lower = LowestDose, upper = max(data@doseGrid))$par)
      MaxGain <- -(optim(LowestDose, Gainfun, method = "L-BFGS-B", lower = LowestDose, upper = max(data@doseGrid))$value)
      if (data@placebo) {
        logGstar <- log(Gstar + Effmodel@const)
      } else {
        logGstar <- log(Gstar)
      }



      ## From paper (Yeung et. al 2015)

      meanEffGstar <- Effmodel@theta1 + Effmodel@theta2 * log(logGstar)

      denom <- (model@phi2) * (meanEffGstar) * (1 + logGstar * model@phi2)

      dgphi1 <- -(meanEffGstar * logGstar * model@phi2 - Effmodel@theta2) / denom

      dgphi2 <- -((meanEffGstar) * logGstar + meanEffGstar * (logGstar)^2 * model@phi2 - Effmodel@theta2 * logGstar) / denom

      dgtheta1 <- -(logGstar * model@phi2) / denom

      dgtheta2 <- -(logGstar * exp(model@phi1 + model@phi2 * logGstar) * model@phi2 * log(logGstar) - 1 - exp(model@phi1 + model@phi2 * logGstar)) / denom

      # DLEPRO <- exp(model@phi1+model@phi2*logGstar)

      # dgphi1 <- Effmodel@theta2*DLEPRO - logGstar*model@phi2*meanEffGstar*DLEPRO

      # dgphi2 <- logGstar*DLEPRO *(Effmodel@theta2-(meanEffGstar)+model@phi2)

      # dgtheta1 <- -logGstar*DLEPRO*model@phi2

      # dgtheta2 <- 1+DLEPRO-logGstar*DLEPRO*model@phi2*log(logGstar)

      deltaG <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)


      ## Find the variance of the log Gstar
      ## First find the covariance matrix of all the parameters, phi1, phi2, theta1 and theta2
      ## such that phi1 and phi2 and independent of theta1 and theta2
      emptyMatrix <- matrix(0, 2, 2)
      covBETA <- cbind(rbind(model@Pcov, emptyMatrix), rbind(emptyMatrix, Effmodel@Pcov))
      varlogGstar <- as.vector(t(deltaG) %*% covBETA %*% deltaG)

      ## Find the upper and lower limit of the 95% credibility interval of Gstar
      CIGstar <- exp(logGstar + c(-1, 1) * 1.96 * sqrt(varlogGstar))

      ## The ratio of the upper to the lower 95% credibility interval
      ratioGstar <- CIGstar[2] / CIGstar[1]

      ## Find the variance of the log of the TDtargetEndOfTrial(eta)
      M1 <- matrix(c(-1 / (model@phi2), -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2), 1, 2)
      M2 <- model@Pcov

      varEta <- as.vector(M1 %*% M2 %*% t(M1))

      ## Find the upper and lower limit of the 95% credibility interval of
      ## TDtargetEndOfTrial
      CITDEOT <- exp(log(TDtargetEndOfTrial) + c(-1, 1) * 1.96 * sqrt(varEta))

      ## The ratio of the upper to the lower 95% credibility interval
      ratioTDEOT <- CITDEOT[2] / CITDEOT[1]

      if (Gstar <= TDtargetEndOfTrial) {
        chooseTD <- FALSE
        CI <- c()
        CI[2] <- CIGstar[2]
        CI[1] <- CIGstar[1]
        ratio <- ratioGstar
      } else {
        chooseTD <- TRUE
        CI <- c()
        CI[2] <- CITDEOT[2]
        CI[1] <- CITDEOT[1]
        ratio <- ratioTDEOT
      }
      ## so can we stop?
      doStop <- ratio <= stopping@target_ratio
      ## generate message

      text1 <- paste(
        "Gstar estimate is", round(Gstar, 4), "with 95% CI (", round(CIGstar[1], 4), ",", round(CIGstar[2], 4),
        ") and its ratio =",
        round(ratioGstar, 4)
      )
      text2 <- paste(
        "TDtargetEndOfTrial estimate is ", round(TDtargetEndOfTrial, 4),
        "with 95% CI (", round(CITDEOT[1], 4), ",", round(CITDEOT[2], 4), ") and its ratio=",
        round(ratioTDEOT, 4)
      )
      text3 <- paste(
        ifelse(chooseTD, "TDatrgetEndOfTrial estimate", "Gstar estimate"), "is smaller with ratio =",
        round(ratio, 4), "which is ", ifelse(doStop, "is less than or equal to", "greater than"),
        "target_ratio =", stopping@target_ratio
      )
      text <- c(text1, text2, text3)
      ## return both
      return(structure(doStop,
        message = text,
        report_label = stopping@report_label
      ))
    }
)


## ============================================================

## -----------------------------------------------------
## Determine the safety window length of the next cohort
## -----------------------------------------------------

##' Determine the safety window length of the next cohort
##'
##' This function determines the safety window length of
##' the next cohort.
##'
##' @param safetyWindow The rule, an object of class
##' \code{\linkS4class{SafetyWindow}}
##' @param size The next cohort size
##' @param data The data input, an object of class \code{\linkS4class{DataDA}}
##' @param \dots additional arguments
##'
##' @return the `windowLength` as a list of safety window parameters
##' (`gap`, `follow`, `follow_min`)
##'
##' @export
##' @keywords methods
setGeneric("windowLength",
  def =
    function(safetyWindow, size, ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("windowLength")
    },
  valueClass = "list"
)


## ============================================================

## --------------------------------------------------
## The SafetyWindowSize method
## --------------------------------------------------

##' @describeIn windowLength Determine safety window length based
##' on the cohort size
##'
##' @example examples/Rules-method-windowLength-SafetyWindowSize.R
setMethod("windowLength",
  signature =
    signature(
      safetyWindow = "SafetyWindowSize",
      size = "ANY"
    ),
  def =
    function(safetyWindow, size, data, ...) {
      ## determine in which interval the next size is
      interval <-
        findInterval(
          x = size,
          vec = safetyWindow@size
        )

      ## so the safety window length is
      patientGap <- head(c(
        0, safetyWindow@gap[[interval]],
        rep(tail(safetyWindow@gap[[interval]], 1), 100)
      ), size)
      patientFollow <- safetyWindow@follow
      patientFollowMin <- safetyWindow@follow_min

      ret <- list(patientGap = patientGap, patientFollow = patientFollow, patientFollowMin = patientFollowMin)

      return(ret)
    }
)

## ============================================================

## --------------------------------------------------
## Constant safety window length
## --------------------------------------------------

##' @describeIn windowLength Constant safety window length
##' @example examples/Rules-method-windowLength-SafetyWindowConst.R
setMethod("windowLength",
  signature =
    signature(
      safetyWindow = "SafetyWindowConst",
      size = "ANY"
    ),
  def =
    function(safetyWindow, size, ...) {
      ## first element should be 0.
      patientGap <- head(c(
        0, safetyWindow@gap,
        rep(tail(safetyWindow@gap, 1), 100)
      ), size)
      patientFollow <- safetyWindow@follow
      patientFollowMin <- safetyWindow@follow_min

      ret <- list(
        patientGap = patientGap,
        patientFollow = patientFollow,
        patientFollowMin = patientFollowMin
      )

      return(ret)
    }
)

# nolint end

# tidy ----

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeDLT ----

#' @rdname tidy
#' @aliases tidy-CohortSizeDLT
#' @example examples/Rules-method-tidyCohortSizeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeMin ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMin
#' @example examples/Rules-method-tidyCohortSizeMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeMax ----

#' @rdname tidy
#' @aliases tidy-CohortSizeMax
#' @example examples/Rules-method-tidyCohortSizeMax.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeMax"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-CohortSizeRange ----

#' @rdname tidy
#' @aliases tidy-CohortSizeRange
#' @example examples/Rules-method-tidyCohortSizeRange.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeRange"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(max > 0) %>%
      tibble::add_column(cohort_size = x@cohort_size) %>%
      h_tidy_class(x)
  }
)

## tidy-CohortSizeParts ----

#' @rdname tidy
#' @aliases tidy-CohortSizeParts
#' @example examples/Rules-method-tidyCohortSizeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CohortSizeParts"),
  definition = function(x, ...) {
    tibble::tibble(
      part = seq_along(x@cohort_sizes),
      cohort_size = x@cohort_sizes
    ) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsMin ----

#' @rdname tidy
#' @aliases tidy-IncrementsMin
#' @example examples/Rules-method-tidyIncrementsMin.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsMin"),
  definition = function(x, ...) {
    callNextMethod() %>% h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelative
#' @example examples/Rules-method-tidyIncrementsRelative.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelative"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelativeDLT ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeDLT
#' @example examples/Rules-method-tidyIncrementsRelativeDLT.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeDLT"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      h_range_to_minmax(.data$intervals) %>%
      dplyr::filter(dplyr::row_number() > 1) %>%
      tibble::add_column(increment = x@increments) %>%
      h_tidy_class(x)
  }
)

## tidy-IncrementsRelative ----

#' @rdname tidy
#' @aliases tidy-IncrementsRelativeParts
#' @example examples/Rules-method-tidyIncrementsRelativeParts.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "IncrementsRelativeParts"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        rv[[nm]] <- h_tidy_slot(x, nm, ...)
      }
    }
    # Column bind of all list elements have the same number of rows.
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv <- rv %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

## tidy-NextBestNCRM ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRM
#' @example examples/Rules-method-tidyNextBestNCRM.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRM"),
  definition = function(x, ...) {
    h_tidy_all_slots(x) %>%
      dplyr::bind_cols() %>%
      h_range_to_minmax(.data$target, range_min = 0, range_max = 1) %>%
      add_column(max_prob = c(NA, NA, x@max_overdose_prob)) %>%
      add_column(Range = c("Underdose", "Target", "Overdose"), .before = 1) %>%
      h_tidy_class(x)
  }
)

## tidy-NextBestNCRMLoss ----

#' @rdname tidy
#' @aliases tidy-NextBestNCRMLoss
#' @example examples/Rules-method-tidyNextBestNCRMLoss.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "NextBestNCRMLoss"),
  definition = function(x, ...) {
    tibble(
      Range = "Underdose",
      Lower = 0,
      Upper = x@target[1]
    ) %>%
      dplyr::bind_rows(
        lapply(
          c("target", "overdose", "unacceptable"),
          function(nm, obj) {
            tibble::tibble(
              Range = stringr::str_to_sentence(nm),
              Lower = slot(obj, nm)[1],
              Upper = slot(obj, nm)[2]
            )
          },
          obj = x
        ) %>% dplyr::bind_rows()
      ) %>%
      add_column(LossCoefficient = x@losses) %>%
      add_column(MaxOverdoseProb = x@max_overdose_prob) %>%
      h_tidy_class(x)
  }
)

# for nextBest methods ----

## some specific helpers ----

#' Calculating the Information Theoretic Distance
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which provides the value of the
#' divergence as given by equation in (7) in the reference at
#' https://doi.org/10.1002/sim.8450.
#'
#' @param prob (`numeric`)\cr vector or matrix with probabilities of a DLT occurring.
#' @param target (`number `)\cr single target probability of a DLT.
#' @param asymmetry (`number`)\cr describes the rate of penalization
#'   for overly toxic does, range 0 to 2.
#'
#' @export
#' @examples
#' h_info_theory_dist(c(0.5, 0.2), 0.4, 1.2)
h_info_theory_dist <- function(prob, target, asymmetry) {
  assert_probabilities(prob)
  assert_true(test_vector(prob) || test_matrix(prob))
  assert_number(target, finite = TRUE)
  assert_number(asymmetry, lower = 0, upper = 2)

  ((prob - target)^2) / (((prob^asymmetry) * (1 - prob)^(2 - asymmetry)))
}

#' Credibility Intervals for Max Gain and Target Doses at `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function for [`nextBest-NextBestMaxGain()`] method. It computes a
#' 95% credibility intervals for given target dose and max gain dose.
#' It also returns a ratio of upper and lower bounds of the interval.
#'
#' @param dose_target (`number`)\cr target dose estimate.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param prob_target (`proportion`)\cr target DLT probability.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the dose grid used
#'   is considered as placebo. This is needed to adjust the max gain dose using
#'   efficacy constant value. If the `placebo` was used, then the `model_eff@const`
#'   is added to `dose_mg`.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @references
#'   Yeung, W.Y., Whitehead, J., Reigner, B., Beyer, U., Diack, Ch., Jaki, T. (2015),
#'   Bayesian adaptive dose-escalation procedures for binary and continuous responses utilizing a gain function,
#'   *Pharmaceutical Statistics*,
#'   \doi{10.1002/pst.1706} \cr
#'
#' @export
#'
h_next_best_mg_ci <- function(dose_target,
                              dose_mg,
                              prob_target,
                              placebo,
                              model,
                              model_eff) {
  assert_number(dose_target, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)
  assert_probability(prob_target)
  assert_flag(placebo)
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  # Find the variance of the log of target dose.
  mat <- matrix(
    c(
      -1 / (model@phi2),
      -(log(prob_target / (1 - prob_target)) - model@phi1) / (model@phi2)^2
    ),
    nrow = 1
  )
  var_dose_target <- as.vector(mat %*% model@Pcov %*% t(mat))

  # 95% credibility interval for target dose.
  ci_dose_target <- exp(log(dose_target) + c(-1, 1) * 1.96 * sqrt(var_dose_target))
  cir_dose_target <- ci_dose_target[2] / ci_dose_target[1]

  # Find the variance of the log of dose_mg.
  # First, find the covariance matrix of all the parameters, phi1, phi2, theta1 and theta2
  # given that phi1 and phi2 are independent of theta1 and theta2.
  log_dose_mg <- log(dose_mg + ifelse(placebo, model_eff@const, 0))

  # Find a delta_g matrix for a variance according to Yeung et. al (2015).
  mean_eff_mg <- model_eff@theta1 + model_eff@theta2 * log(log_dose_mg)
  denom <- model@phi2 * mean_eff_mg * (1 + model@phi2 * log_dose_mg)
  dgphi1 <- -(mean_eff_mg * log_dose_mg * model@phi2 - model_eff@theta2) / denom
  dgphi2 <- -(log_dose_mg * (mean_eff_mg * (1 + log_dose_mg * model@phi2) - model_eff@theta2)) / denom
  dgtheta1 <- -(log_dose_mg * model@phi2) / denom
  dgtheta2_num <- -(exp(model@phi1 + model@phi2 * log_dose_mg) * (model@phi2 * log_dose_mg * log(log_dose_mg) - 1) - 1)
  dgtheta2 <- dgtheta2_num / denom
  delta_g <- matrix(c(dgphi1, dgphi2, dgtheta1, dgtheta2), 4, 1)

  zero_matrix <- matrix(0, 2, 2)
  cov_beta <- cbind(rbind(model@Pcov, zero_matrix), rbind(zero_matrix, model_eff@Pcov))
  var_log_dose_mg <- as.vector(t(delta_g) %*% cov_beta %*% delta_g)

  # 95% credibility interval for max gain dose.
  ci_mg <- exp(log_dose_mg + c(-1, 1) * 1.96 * sqrt(var_log_dose_mg))
  ci_ratio_mg <- ci_mg[2] / ci_mg[1]

  list(
    ci_dose_target = ci_dose_target,
    ci_ratio_dose_target = cir_dose_target,
    ci_dose_mg = ci_mg,
    ci_ratio_dose_mg = ci_ratio_mg
  )
}

## next best at grid ----

#' Get Closest Grid Doses for a Given Target Doses for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that for a given target doses finds the dose in grid that is
#' closest and below the target. There are four different targets in the context
#' of [`nextBest-NextBestMaxGain()`] method: \eqn{min(`dose_mg`, `dose_target_drt`)},
#' `dose_mg`, `dose_target_drt` or `dose_target_eot`.
#'
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#'
#' @export
#'
h_next_best_mg_doses_at_grid <- function(dose_target_drt,
                                         dose_target_eot,
                                         dose_mg,
                                         dose_grid,
                                         doselimit,
                                         placebo) {
  assert_number(dose_target_drt, na.ok = TRUE)
  assert_number(dose_target_eot, na.ok = TRUE)
  assert_number(dose_mg, na.ok = TRUE)

  doses_eligible <- h_next_best_eligible_doses(dose_grid, doselimit, placebo)

  # h_find_interval assumes that elements in doses_eligible are strictly increasing.
  next_dose_lev <- h_find_interval(min(dose_mg, dose_target_drt), doses_eligible)
  next_dose <- doses_eligible[next_dose_lev]

  next_dose_mg_lev <- h_find_interval(dose_mg, doses_eligible)
  next_dose_mg <- doses_eligible[next_dose_mg_lev]

  next_dose_lev_drt <- h_find_interval(dose_target_drt, doses_eligible)
  next_dose_drt <- doses_eligible[next_dose_lev_drt]

  next_dose_lev_eot <- h_find_interval(dose_target_eot, doses_eligible)
  next_dose_eot <- doses_eligible[next_dose_lev_eot]

  next_dose_list <- list(
    next_dose = next_dose,
    next_dose_drt = next_dose_drt,
    next_dose_eot = next_dose_eot,
    next_dose_mg = next_dose_mg
  )
}

## eligible doses ----

#' Get Eligible Doses from the Dose Grid.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function that gets the eligible doses from the dose grid.
#' The eligible doses are the doses which do not exceed a given
#' `doselimit`. For placebo design, if safety allows (i.e. if there is at least
#' one non-placebo dose which does not exceed the dose limit), the placebo dose
#' it then excluded from the eligible doses.
#'
#' @param dose_grid (`numeric`)\cr all possible doses.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level in the `dose_grid`
#'   is considered as placebo.
#' @param levels (`flag`)\cr if `TRUE` the levels of eligible doses are returned,
#'   otherwise, the doses (default).
#'
#' @return A numeric vector with eligible doses or eligible dose levels if `levels`
#'   flag is `TRUE`.
#'
#' @export
#' @examples
#' dose_grid <- c(0.001, seq(25, 200, 25))
#' h_next_best_eligible_doses(dose_grid, 79, TRUE)
#' h_next_best_eligible_doses(dose_grid, 24, TRUE)
h_next_best_eligible_doses <- function(dose_grid,
                                       doselimit,
                                       placebo,
                                       levels = FALSE) {
  assert_numeric(dose_grid, finite = TRUE, any.missing = FALSE, min.len = 1L, sorted = TRUE)
  assert_number(doselimit)
  assert_flag(placebo)
  assert_flag(levels)

  is_dose_eligible <- dose_grid <= doselimit
  if (placebo && sum(is_dose_eligible) > 1L) {
    is_dose_eligible[1] <- FALSE
  }

  if (levels) {
    is_dose_eligible
  } else {
    dose_grid[is_dose_eligible]
  }
}

## plot ----

#' Building the Plot for `nextBest-NextBestNCRMLoss` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestNCRMLoss()`]
#' method.
#'
#' @param prob_mat (`numeric`)\cr matrix with probabilities of a grid doses
#'   to be in a given interval. If `is_unacceptable_specified` is `TRUE`, there
#'   must be 4 intervals (columns) in `prob_mat`: `underdosing`, `target`,
#'   `excessive`, `unacceptable`. Otherwise, there must be 3 intervals (columns):
#'   `underdosing`, `target`, `overdose`. Number of rows must be equal to number
#'   of doses in a grid.
#' @param posterior_loss (`numeric`)\cr posterior losses.
#' @param max_overdose_prob (`number`)\cr maximum overdose posterior
#'   probability that is allowed.
#' @param dose_grid (`numeric`)\cr dose grid.
#' @param max_eligible_dose_level (`number`)\cr maximum eligible dose level in
#'   the `dose_grid`.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#' @param is_unacceptable_specified (`flag`)\cr is unacceptable interval specified?
#'
#' @export
h_next_best_ncrm_loss_plot <- function(prob_mat,
                                       posterior_loss,
                                       max_overdose_prob,
                                       dose_grid,
                                       max_eligible_dose_level,
                                       doselimit,
                                       next_dose,
                                       is_unacceptable_specified) {
  assert_numeric(dose_grid, finite = TRUE, any.missing = FALSE, sorted = TRUE)
  n_grid <- length(dose_grid)
  assert_flag(is_unacceptable_specified)
  assert_probabilities(prob_mat)
  assert_matrix(prob_mat, min.cols = 3, max.cols = 4, nrows = n_grid, col.names = "named")
  if (!is_unacceptable_specified) {
    assert_names(colnames(prob_mat), permutation.of = c("underdosing", "target", "overdose"))
  } else {
    assert_names(colnames(prob_mat), permutation.of = c("underdosing", "target", "excessive", "unacceptable"))
  }
  assert_numeric(posterior_loss, finite = TRUE, any.missing = FALSE, len = n_grid)
  assert_probability(max_overdose_prob)
  assert_number(max_eligible_dose_level, lower = 0, upper = n_grid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  # Build plots, first for the target probability.
  p1 <- ggplot() +
    geom_bar(
      data = data.frame(Dose = dose_grid, y = prob_mat[, "target"] * 100),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    ylim(c(0, 100)) +
    ylab(paste("Target probability [%]"))

  if (is.finite(doselimit)) {
    p1 <- p1 + geom_vline(xintercept = doselimit, lwd = 1.1, lty = 2, colour = "black")
  }

  if (max_eligible_dose_level > 0) {
    p1 <- p1 +
      geom_vline(xintercept = dose_grid[max_eligible_dose_level], lwd = 1.1, lty = 2, colour = "red")
  }

  p_loss <- ggplot() +
    # For the loss function.
    geom_bar(
      data = data.frame(Dose = dose_grid, y = posterior_loss),
      aes(x = .data$Dose, y = .data$y),
      stat = "identity",
      position = "identity",
      width = min(diff(dose_grid)) / 2,
      colour = "darkgreen",
      fill = "darkgreen"
    ) +
    geom_point(
      aes(x = next_dose, y = max(posterior_loss) + 0.2),
      size = 3,
      pch = 25,
      col = "red",
      bg = "red"
    ) +
    ylab(paste("Loss function"))

  if (!is_unacceptable_specified) {
    # Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "overdose"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      geom_hline(
        yintercept = max_overdose_prob * 100, lwd = 1.1, lty = 2,
        colour = "black"
      ) +
      ylim(c(0, 100)) +
      ylab("Overdose probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p_loss, nrow = 3)
  } else {
    # Plot in case of 4 toxicity intervals. Second, for the overdosing probability.
    p2 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "excessive"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Excessive probability [%]")

    p3 <- ggplot() +
      geom_bar(
        data = data.frame(Dose = dose_grid, y = prob_mat[, "unacceptable"] * 100),
        aes(x = .data$Dose, y = .data$y),
        stat = "identity",
        position = "identity",
        width = min(diff(dose_grid)) / 2,
        colour = "red",
        fill = "red"
      ) +
      ylim(c(0, 100)) +
      ylab("Unacceptable probability [%]")

    # Combine it all together.
    plots_single <- list(plot1 = p1, plot2 = p2, plot3 = p3, plot_loss = p_loss)
    plot_joint <- gridExtra::arrangeGrob(p1, p2, p3, p_loss, nrow = 4)
  }

  list(plots_single = plots_single, plot_joint = plot_joint)
}

#' Building the Plot for `nextBest-NextBestTDsamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTDsamples()`]
#' method.
#'
#' @param dose_target_drt_samples (`numeric`)\cr vector of in-trial samples.
#' @param dose_target_eot_samples (`numeric`)\cr vector of end-of-trial samples.
#' @param dose_target_drt (`number`)\cr target in-trial estimate.
#' @param dose_target_eot (`number`)\cr target end-of-trial estimate.
#' @param dose_grid_range (`numeric`)\cr range of dose grid.
#' @param nextBest (`NextBestTDsamples`)\cr the rule for the next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_tdsamples_plot <- function(dose_target_drt_samples,
                                       dose_target_eot_samples,
                                       dose_target_drt,
                                       dose_target_eot,
                                       dose_grid_range,
                                       nextBest,
                                       doselimit,
                                       next_dose) {
  assert_numeric(dose_target_drt_samples, any.missing = FALSE)
  assert_numeric(dose_target_eot_samples, any.missing = FALSE)
  assert_number(dose_target_drt)
  assert_number(dose_target_eot)
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_class(nextBest, "NextBestTDsamples")
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  lbl1 <- paste("TD", nextBest@prob_target_drt * 100, "Estimate")
  lbl2 <- paste("TD", nextBest@prob_target_eot * 100, "Estimate")
  labels <- data.frame(
    Type = c("during", "end", "Max", "Next"),
    Alpha = c(0.25, 0.25, 1, 1),
    x = c(
      dose_target_drt,
      dose_target_eot,
      min(doselimit, dose_grid_range[2]),
      next_dose
    )
  )
  p <- ggplot(
    data = rbind(
      data.frame(period = "during", TD = dose_target_drt_samples),
      data.frame(period = "end", TD = dose_target_eot_samples)
    ),
    aes(x = .data$TD, colour = .data$period),
  ) +
    geom_density(
      aes(fill = .data$period, colour = .data$period),
      alpha = 0.25,
      bounds = dose_grid_range,
      show.legend = FALSE
    ) +
    geom_vline(data = labels, aes(xintercept = x, colour = Type)) +
    ylab("Posterior density") +
    scale_colour_manual(
      name = NULL,
      values = c("during" = "orange", "end" = "violet", "Max" = "red", "Next" = "blue"),
      labels = c("during" = lbl1, "end" = lbl2, "Max" = "Max", "Next" = "Next")
    ) +
    scale_fill_manual(
      values = c("during" = "orange", "end" = "violet")
    )
}

#' Building the Plot for `nextBest-NextBestTD` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestTD()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param data (`Data`)\cr the data object from which the dose grid will be fetched.
#' @param prob_dlt (`numeric`)\cr DLT probabilities for doses in grid.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param next_dose (`number`)\cr next best dose.
#'
#' @export
#'
h_next_best_td_plot <- function(prob_target_drt,
                                dose_target_drt,
                                prob_target_eot,
                                dose_target_eot,
                                data,
                                prob_dlt,
                                doselimit,
                                next_dose) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_class(data, "Data")
  assert_probabilities(prob_dlt, len = data@nGrid)
  assert_number(doselimit)
  assert_number(next_dose, na.ok = TRUE)

  dosegrid_range <- dose_grid_range(data)

  p <- ggplot(
    data = data.frame(x = data@doseGrid, y = prob_dlt),
    aes(x = .data$x, y = .data$y)
  ) +
    geom_line(colour = "red", linewidth = 1.5) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(c(0, 1)) +
    xlab("Dose Levels") +
    ylab("Probability of DLT")
  if (h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = TRUE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_drt * 100, "Estimate"),
        x = dose_target_drt + 1,
        y = prob_target_drt - 0.2,
        size = 5,
        colour = "orange"
      )
  }

  if (h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = TRUE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text",
        label = paste("TD", prob_target_eot * 100, "Estimate"),
        x = dose_target_eot + 1,
        y = prob_target_eot - 0.1,
        size = 5,
        colour = "violet"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    geom_text(
      data = data.frame(x = maxdoselimit, y = 0),
      aes(x = .data$x, y = .data$y, label = "Max", hjust = +1, vjust = -30),
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      colour = "brown",
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    geom_text(
      data = data.frame(x = next_dose, y = 0),
      aes(x = .data$x, y = .data$y, label = "Next", hjust = 0, vjust = -30),
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGain` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGain()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param max_gain (`number`)\cr the maximum gain estimate.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param data (`DataDual`)\cr the data object from which the dose grid will be fetched.
#' @param model (`ModelTox`)\cr the DLT model.
#' @param model_eff (`Effloglog`)\cr the efficacy model.
#'
#' @export
#'
h_next_best_mg_plot <- function(prob_target_drt,
                                dose_target_drt,
                                prob_target_eot,
                                dose_target_eot,
                                dose_mg,
                                max_gain,
                                next_dose,
                                doselimit,
                                data,
                                model,
                                model_eff) {
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_number(max_gain, na.ok = TRUE)
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)
  assert_class(data, "Data")
  assert_class(model, "ModelTox")
  assert_class(model_eff, "Effloglog")

  dosegrid_range <- dose_grid_range(data)

  data_plot <- data.frame(
    dose = rep(data@doseGrid, 3),
    y = c(
      prob(dose = data@doseGrid, model = model),
      efficacy(dose = data@doseGrid, model = model_eff),
      gain(dose = data@doseGrid, model_dle = model, model_eff = model_eff)
    ),
    group = c(
      rep("p(DLE)", data@nGrid),
      rep("Expected Efficacy", data@nGrid),
      rep("Gain", data@nGrid)
    )
  )

  p <- ggplot(data = data_plot, aes(x = .data$dose, y = .data$y)) +
    geom_line(aes(group = group, color = group), linewidth = 1.5) +
    ggplot2::scale_colour_manual(name = "curves", values = c("blue", "green3", "red")) +
    coord_cartesian(xlim = c(0, dosegrid_range[2])) +
    ylim(range(data_plot$y)) +
    xlab("Dose Level") +
    ylab("Values")

  if (h_in_range(dose_target_eot, range = dosegrid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_eot, y = prob_target_eot),
        aes(x = .data$x, y = .data$y),
        colour = "violet",
        shape = 16,
        size = 8
      ) +
      annotate(
        geom = "text", label = lab, x = dose_target_eot - 1, y = 0.2, size = 5, colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dosegrid_range, bounds_closed = FALSE)) {
    p <- p +
      geom_point(
        data = data.frame(x = dose_mg, y = max_gain),
        aes(x = .data$x, y = .data$y),
        colour = "green3",
        shape = 17,
        size = 8
      ) +
      annotate(
        "text",
        label = "Max Gain Estimate", x = dose_mg, y = max_gain - 0.1, size = 5, colour = "green3"
      )
  }

  if (h_in_range(dose_target_drt, range = dosegrid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_point(
        data = data.frame(x = dose_target_drt, y = prob_target_drt),
        aes(x = .data$x, y = .data$y),
        colour = "orange",
        shape = 15,
        size = 8
      ) +
      annotate(
        geom = "text", label = lab, x = dose_target_drt + 25, y = prob_target_drt + 0.01, size = 5, colour = "orange"
      )
  }

  maxdoselimit <- min(doselimit, dosegrid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "brown", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Max",
      x = maxdoselimit - 2,
      y = max(data_plot$y),
      size = 5,
      angle = 90,
      vjust = -0.5,
      hjust = 0.5,
      colour = "brown"
    ) +
    geom_vline(xintercept = next_dose, colour = "purple", lwd = 1.1) +
    annotate(
      geom = "text",
      label = "Next",
      x = next_dose + 1,
      y = max(data_plot$y) - 0.05,
      size = 5,
      angle = 90,
      vjust = 1.5,
      hjust = 0.5,
      color = "purple"
    )
}

#' Building the Plot for `nextBest-NextBestMaxGainSamples` Method.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper function which creates the plot for [`nextBest-NextBestMaxGainSamples()`] method.
#'
#' @param prob_target_drt (`proportion`)\cr target DLT probability during the trial.
#' @param dose_target_drt (`number`)\cr target dose estimate during the trial.
#' @param prob_target_eot (`proportion`)\cr target DLT probability at the end of the trial.
#' @param dose_target_eot (`number`)\cr target dose estimate at the end of the trial.
#' @param dose_mg (`number`)\cr the dose corresponding to the maximum gain.
#' @param dose_mg_samples (`numeric`)\cr for every sample, the dose (from the dose grid)
#'   that gives the maximum gain value.
#' @param next_dose (`number`)\cr next best dose.
#' @param doselimit (`number`)\cr the maximum allowed next dose.
#' @param dose_grid_range (`numeric`)\cr dose grid range.
#'
#' @export
#'
h_next_best_mgsamples_plot <- function(prob_target_drt,
                                       dose_target_drt,
                                       prob_target_eot,
                                       dose_target_eot,
                                       dose_mg,
                                       dose_mg_samples,
                                       next_dose,
                                       doselimit,
                                       dose_grid_range) {
  assert_range(dose_grid_range, finite = TRUE, unique = FALSE)
  assert_probability(prob_target_drt)
  assert_number(dose_target_drt)
  assert_probability(prob_target_eot)
  assert_number(dose_target_eot)
  assert_number(dose_mg, na.ok = TRUE)
  assert_numeric(
    dose_mg_samples,
    lower = dose_grid_range[1], upper = dose_grid_range[2], finite = TRUE, any.missing = FALSE
  )
  assert_number(next_dose, na.ok = TRUE)
  assert_number(doselimit)

  p <- ggplot() +
    geom_histogram(
      data = data.frame(Gstar = dose_mg_samples),
      aes(x = .data$Gstar),
      fill = "darkgreen",
      colour = "green3",
      binwidth = 25
    ) +
    coord_cartesian(xlim = c(0, dose_grid_range[2])) +
    ylab("Posterior density")

  if (h_in_range(dose_target_drt, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_drt * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_drt, colour = "orange", lwd = 1.1) +
      annotate(
        geom = "text", label = lab, x = dose_target_drt, y = 0, hjust = -0.1, vjust = -20, size = 5, colour = "orange"
      )
  }

  if (h_in_range(dose_target_eot, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- paste("TD", prob_target_eot * 100, "Estimate")
    p <- p +
      geom_vline(xintercept = dose_target_eot, colour = "violet", lwd = 1.1) +
      annotate(
        geom = "text", label = lab, x = dose_target_eot, y = 0, hjust = -0.1, vjust = -25, size = 5, colour = "violet"
      )
  }

  if (h_in_range(dose_mg, range = dose_grid_range, bounds_closed = FALSE)) {
    lab <- "Gstar Estimate"
    p <- p +
      geom_vline(xintercept = dose_mg, colour = "green", lwd = 1.1) +
      annotate(
        geom = "text", label = lab, x = dose_mg, y = 0, hjust = -0.1, vjust = -25, size = 5, colour = "green"
      )
  }

  maxdoselimit <- min(doselimit, dose_grid_range[2])

  p +
    geom_vline(xintercept = maxdoselimit, colour = "red", lwd = 1.1) +
    annotate(
      geom = "text", label = "Max", x = maxdoselimit, y = 0, hjust = +1, vjust = -35, colour = "red"
    ) +
    geom_vline(xintercept = next_dose, colour = "blue", lwd = 1.1) +
    annotate(
      geom = "text", label = "Next", x = next_dose, y = 0, hjust = 0.1, vjust = -30, colour = "blue"
    )
}

# These functions will need to be amended to support the report_label slot if
# and when it is added to NextBest classes

# NextBestMTD ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param target_label (`character`)\cr the term used to describe the target
#' toxicity rate
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMTD
knit_print.NextBestMTD <- function(
    x,
    ...,
    target_label = "the 25th centile",
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(target_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose level recommended for the next cohort will be selected as follows:\n\n",
    "-  First, ",
    target_label,
    " of the posterior distribution of ",
    tox_label,
    " will be calculated for all dose levels that are eligible according to the ",
    " Increments rule.\n",
    "-  Next, the \"target dose\" (which may not be part of the dose grid) for which ",
    target_label,
    " of the posterior distribution of ",
    tox_label,
    " is exactly equal to the target rate of ",
    x@target,
    " will be determined.\n",
    "- Finally, the dose level whose absolute distance from the target dose ",
    "is smallest will be selected as the recommended dose for the next cohort\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestNCRM ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestNCRM
knit_print.NextBestNCRM <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way.  First, doses that are ineligible according to the increments rule ",
    "will be discarded.  Next, any dose for which the mean posterior probability of ",
    tox_label,
    " being in the overdose range - (",
    x@overdose[1], ", ", x@overdose[2],
    "] - is ",
    x@max_overdose_prob,
    " or more will also be discarded.  Finally, the dose amongst those remaining ",
    "which has the highest chance that the mean posterior probability of ",
    tox_label,
    " is in the target ",
    tox_label,
    " range of ",
    x@target[1],
    " to ",
    x@target[2],
    " (inclusive) will be selected."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestThreePlusThree ----

#' @description `r lifecycle::badge("experimental")`
#' @param participant_label (`character`)\cr The term used to label the participants.
#' @param tox_label (`character`)\cr the term used to describe toxicity.  See
#' Usage Notes below.
#' See Usage Notes below.
#' @section Usage Notes:
#' This section describes the use of `participant_label` and `tox_label`, collectively
#' referred to as `label`s.
#' A `label` should be a scalar or a vector of length 2.  If a scalar, it is
#' converted by adding a second element that is equal to the first, suffixed by `s`.
#' For example, `tox_label = "DLT"` becomes `tox_label = c("DLT", "DLTs")`.  The
#' first element of the vector is used to describe a count of 1.  The second
#' is used in all other cases.
#' @rdname knit_print
#' @export
#' @method knit_print NextBestThreePlusThree
knit_print.NextBestThreePlusThree <- function(
    x,
    ...,
    tox_label = c("toxicity", "toxicities"),
    participant_label = "participant",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, min.len = 1, max.len = 2, any.missing = FALSE)

  # Prepare
  if (length(tox_label == 1)) {
    tox_label <- c(tox_label, paste0(tox_label, "s"))
  }
  if (length(participant_label == 1)) {
    participant_label <- c(participant_label, paste0(participant_label, "s"))
  }

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen using the \"Three ",
    "Plus Three\" rule.\n\n- If no ",
    tox_label[2],
    " have been reported at the current dose level, escalate by one dose level.\n",
    "- If the observed ",
    tox_label[1],
    " rate at the current dose level is exactly 1/3 and no more than three ",
    participant_label[2],
    " treated at the current dose level are evaluable, remain at the current ",
    "dose level.\n",
    "- Otherwise, recommend that the trial stops and identify the MTD as dose ",
    "level immediately below the current one."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestDualEndpoint ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
#' @param biomarker_units (`character`)\cr the units in which the biomarker is
#' measured
#' @rdname knit_print
#' @export
#' @method knit_print NextBestDualEndpoint
knit_print.NextBestDualEndpoint <- function(
    x,
    ...,
    tox_label = "toxicity",
    biomarker_label = "the biomarker",
    biomarker_units = ifelse(x@target_relative, "%", ""),
    asis = TRUE) {
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(biomarker_label, len = 1, any.missing = FALSE)
  assert_character(biomarker_units, len = 1, any.missing = FALSE)

  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way.  First, doses that are ineligible according to the increments rule ",
    "will be discarded.  Next, any dose for which the mean posterior probability of ",
    tox_label,
    " being in the overdose range - (",
    x@overdose[1], ", ", x@overdose[2],
    "] - is ",
    x@max_overdose_prob,
    " or more will also be discarded.  Finally, the dose amongst those remaining ",
    "which has the highest chance that the mean posterior probability that ",
    biomarker_label,
    " is in the target range for ",
    biomarker_label,
    ", which is ",
    x@target[1],
    ifelse(x@target_relative, "", stringr::str_squish(paste0(" ", biomarker_units))),
    " to ",
    x@target[2],
    ifelse(x@target_relative, "", stringr::str_squish(paste0(" ", biomarker_units))),
    " (inclusive),",
    ifelse(
      x@target_relative,
      paste0(" of the maximum ", biomarker_label, " value"),
      ""
    ),
    " will be selected, provided that this probability exceeds ",
    x@target_thresh,
    ".  If no dose meets this threshold, then the highest eligible dose will ",
    "be selected."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestMinDist ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMinDist
knit_print.NextBestMinDist <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which has the smallest absolute difference between ",
    "its mean posterior estimate of the probability of ",
    tox_label,
    " and the target ",
    tox_label,
    " rate [",
    x@target,
    "]."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestInfTheory ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param citation_text (`character`)\cr the text used to cite Mozgunov & Jaki
#' @param citation_link (`character`)\cr the link to Mozgunov & Jaki
#' @section Usage Notes:
#' To use a BibTeX-style citation, specify (for example) `citation_text =
#' "@MOZGUNOV", citation_link = ""`.
#' @rdname knit_print
#' @export
#' @method knit_print NextBestInfTheory
knit_print.NextBestInfTheory <- function(
    x,
    ...,
    tox_label = "toxicity",
    citation_text = "Mozgunov & Jaki (2019)",
    citation_link = "https://doi.org/10.1002/sim.8450",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(citation_text, len = 1, any.missing = FALSE)
  assert_character(citation_link, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The recommended dose for the next cohort will be chosen using the ",
    "complex infinite bounds penalisation (CIBP) criterion of ",
    "[", citation_text, "]",
    ifelse(nchar(citation_link) > 0, paste0("(", citation_link, ")"), ""),
    ".  Let\n\n",
    "$$ \\delta(\\hat{p}_d, \\gamma) = \\frac{(\\hat{p}_d - \\gamma)^2}",
    "{\\hat{p}_d^a \\cdot (1 - \\hat{p}_d)^{2 - a}} $$\n\n",
    "where a is the non-centrality parameter with a value of ",
    x@asymmetry,
    ", &gamma; is the target ",
    tox_label,
    " rate with a value of ",
    x@target,
    " and $\\hat{p}_d$ is the mean posterior estimate of the probability of ",
    tox_label,
    " at dose level d.\n\n",
    "The recommended dose for the next cohort will be ",
    "the value of d that minimises $\\delta(\\hat{p}_d, \\gamma)$."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestTD ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestTD
knit_print.NextBestTD <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which is the highest dose in the dose grid strictly less than ",
    "the dose (which may not be in the dose grid) that has a posterior plug-in ",
    "estimate of the probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "]."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestMaxGain ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMaxGain
knit_print.NextBestMaxGain <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is closest to ",
    "Gstar, the dose that maximises the gain for probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "]."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestProbMTDLTE ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestProbMTDLTE
knit_print.NextBestProbMTDLTE <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the dose level with ",
    "the highest probability of being the highest dose with an estimated ",
    "probability of ",
    tox_label,
    " less than or equal to ",
    x@target,
    "."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestProbMTDMinDist ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestProbMTDMinDist
knit_print.NextBestProbMTDMinDist <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the dose level with ",
    "the highest probability of being the highest dose with an estimated ",
    "probability of ",
    tox_label,
    " closest to ",
    x@target,
    "."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestNCRMLoss ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param format_func (`function`)\cr The function used to format the range table.
#' @importFrom rlang .data
#' @rdname knit_print
#' @export
#' @method knit_print NextBestNCRMLoss
knit_print.NextBestNCRMLoss <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE,
    format_func = function(x) {
      kableExtra::kable_styling(
        x,
        bootstrap_options = c("striped", "hover", "condensed")
      )
    }) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  param <- list(...)
  param[["x"]] <- x %>%
    tidy() %>%
    dplyr::select(-.data$MaxOverdoseProb)
  param[["col.names"]] <- c("Range", "Lower", "Upper", "Loss Coefficient")
  rv <- paste0(
    "The dose recommended for the next cohort will be chosen in the following ",
    "way:\n\n-  First, the chance that the probability of ",
    tox_label,
    " falls into each of the underdose, target ",
    ifelse(
      any(x@unacceptable != c(1, 1)),
      ", overdose and unacceptable",
      " and overdose"
    ),
    " dose ranges is calculated for element of the dose grid.\n",
    "-  Next, the loss associated with each dose is calculated by multiplying ",
    "these probabilities by the corresponding loss coefficient and summing the result.\n",
    "-  Then ineligible doses, and those with a probability of being in the ",
    ifelse(
      length(x@losses) == 3,
      "overdose range",
      "overdose or unaccaptable ranges"
    ),
    " that is greater than ",
    x@max_overdose_prob,
    ", are discarded.\n",
    "-  Finally, the dose level with the smallest loss is selected as the ",
    "recommended dose for the next cohort.\n\n",
    ifelse(
      toupper(tox_label) == tox_label,
      tox_label,
      stringr::str_to_sentence(tox_label)
    ),
    " ranges and loss coefficients are given in the following table:\n\n",
    paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestTDsamples ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestTDsamples
knit_print.NextBestTDsamples <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is both ",
    "eligible and which is the highest dose in the dose grid strictly less than ",
    "the dose (which may not be in the dose grid) that has a full Bayes posterior ",
    "estimate of the probability of ",
    tox_label,
    " exactly equal to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "]."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}


# NextBestMaxGainSamples ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestMaxGainSamples
knit_print.NextBestMaxGainSamples <- function(
    x,
    ...,
    tox_label = "toxicity",
    asis = TRUE) {
  # Validate
  assert_flag(asis)
  assert_character(tox_label, len = 1, any.missing = FALSE)

  # Execute
  rv <- paste0(
    "The dose recommended for the next cohort will be the one which is closest to ",
    "Gstar, the dose for which the full Bayes posterior estimate of the probability of ",
    tox_label,
    " maximises the gain relative to the target ",
    tox_label,
    " rate, either during [",
    x@prob_target_drt,
    "] or at the end of the trial [",
    x@prob_target_eot,
    "]."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# NextBestOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print NextBestOrdinal
knit_print.NextBestOrdinal <- function(
    x,
    ...,
    asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Update [`DualEndpoint`] class model components with regard to biomarker
#' regression variance.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' to biomarker regression variance `sigma2W`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
#'   regression variance `sigma2W` should be used or not. If `sigma2W` is not
#'   supposed to be a fixed value, a prior distribution from the Inverse-Gamma
#'   distribution will be used. See the details below, under `sigma2W` argument.
#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
#'   Inverse-Gamma distribution parameters, i.e. vector with two elements named
#'   `a` and `b`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_sigma2W <- function(use_fixed, # nolintr
                                          sigma2W,
                                          comp) {
  if (use_fixed) {
    assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
    comp$modelspecs$precW <- 1 / sigma2W
  } else {
    assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        precW ~ dgamma(precWa, precWb)
      }
    )
    comp$modelspecs$precWa <- sigma2W[["a"]]
    comp$modelspecs$precWb <- sigma2W[["b"]]
    comp$init$precW <- 1
    comp$sample <- c(comp$sample, "precW")
  }
  comp
}

#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
#' correlation.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] model existing components
#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
#' DLT and biomarker correlation `rho`.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
#'   biomarker correlation `rho` should be used or not. If `rho` is not supposed
#'   to be a fixed value, a prior distribution from the scaled Beta family will
#'   be used. See the details below, under `rho` argument.
#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
#'   fixed value (between `-1` and `1`), or a named vector with two elements,
#'   named `a` and `b` for the Beta prior on the transformation
#'   `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
#'   leads to a uniform prior on `rho`.
#' @param comp (`list`)\cr a named list with model components that will be updated.
#'   The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
#'   definitions of the components, see [`GeneralModel`] class.
#'   The `modelspecs` and `init` components on `comp` list are specified up to
#'   the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
#'   functions. These bodies are simply a lists itself.
#'
#' @return A `list` with updated model components.
#'
#' @export
h_model_dual_endpoint_rho <- function(use_fixed,
                                      rho,
                                      comp) {
  rmin <- .Machine$double.xmin
  if (use_fixed) {
    assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
    comp$modelspecs$rho <- rho
  } else {
    assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
    comp$priormodel <- h_jags_join_models(
      comp$priormodel,
      function() {
        kappa ~ dbeta(rhoa, rhob)
        rho <- 2 * kappa - 1
      }
    )
    comp$modelspecs$rhoa <- rho[["a"]]
    comp$modelspecs$rhob <- rho[["b"]]
    comp$init$kappa <- 0.5
    comp$sample <- c(comp$sample, "rho")
  }
  comp
}

#' Update certain components of [`DualEndpoint`] model with regard to prior variance
#' factor of the random walk.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
#' variance.
#'
#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
#'   `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
#'   to be a fixed value, a prior distribution from the Inverse-Gamma distribution
#'   will be used. See the details below, under `sigma2betaW` argument.
#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
#'   prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
#'   parameters, i.e. vector with two elements named `a` and `b`.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
#'   `init`, `sample` slots.
#'
#' @seealso [`DualEndpointRW`].
#' @export
h_model_dual_endpoint_sigma2betaW <- function(use_fixed, # nolintr
                                              sigma2betaW,
                                              de) {
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
    ms <- list(precBetaW = 1 / sigma2betaW)
  } else {
    assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
    # gamma prior for random walk precision.
    de@priormodel <- h_jags_join_models(
      de@priormodel,
      function() {
        precBetaW ~ dgamma(precBetaWa, precBetaWb)
      }
    )
    ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
    de@init <- function(y) {
      c(init(y), list(precBetaW = 1))
    }
    de@sample <- c(de@sample, "precBetaW")
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de
}

#' Update certain components of [`DualEndpoint`] model with regard to parameters
#' of the function that models dose-biomarker relationship defined in the
#' [`DualEndpointBeta`] class.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that takes [`DualEndpoint`] object and updates
#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
#' vector. In the later case, it is assumed that `param` represents two
#' parameters of a probability distribution that will be used in `priormodel`
#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
#' See the help page for [`DualEndpointBeta`] class for more details.
#'
#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
#'   the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
#'   scalar or vector with two elements that are the parameters of a probability
#'   distribution that will be used in `priormodel` function to generate values
#'   for the `param_name` parameter of \eqn{f(x)}.
#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
#'   whose value depends on `param`.
#' @param param_suffix (`character`)\cr the two suffixes to be appended to
#'   the elements of `param_name` and then used when updating `modelspecs`.
#'   The value of this argument is ignored when `param` is a scalar.
#' @param priormodel (`function` or `NULL`)\cr a function representing the
#'   `JAGS` prior specification that will be appended to existing
#'   `de@priormodel` specification if `param` is not a scalar. Otherwise,
#'   `de@priormodel` remains unchanged.
#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
#'
#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
#'   `modelspecs`, `init`, `sample` slots.
#'
#' @export
h_model_dual_endpoint_beta <- function(param,
                                       param_name,
                                       param_suffix = c("_low", "_high"),
                                       priormodel = NULL,
                                       de) {
  assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_string(param_name)
  assert_class(de, "DualEndpoint")

  use_fixed <- setNames(test_number(param), param_name)
  modelspecs <- de@modelspecs
  init <- de@init

  if (use_fixed) {
    ms <- setNames(list(param), param_name)
  } else {
    assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
    assert_function(priormodel)
    param_name2 <- paste0(param_name, param_suffix)

    de@priormodel <- h_jags_join_models(
      de@priormodel,
      priormodel
    )
    ms <- setNames(list(param[1], param[2]), param_name2)
    de@init <- function(y) {
      c(init(y), setNames(list(mean(param)), param_name))
    }
    de@sample <- c(de@sample, param_name)
  }
  de@modelspecs <- function(from_prior) {
    c(modelspecs(from_prior), ms)
  }
  de@use_fixed <- c(de@use_fixed, use_fixed)
  de
}

#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
#'
#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
#'   model to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
#' is required.
#' @return A [`LogisticLogNormal`] model.
#'
#' @export
h_convert_ordinal_model <- function(x, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(x, "LogisticLogNormalOrdinal")
  # Execute
  LogisticLogNormal(
    mean = x@params@mean[-grade],
    cov = x@params@cov[-grade, -grade],
    ref_dose = x@ref_dose
  )
}

#' @include Model-class.R
#' @include Samples-class.R
NULL

# doseFunction ----

## generic ----

#' Getting the Dose Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [dose()] method that computes the dose reaching a
#' specific target value of a given independent variable, based on the model
#' specific parameters.
#'
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [dose()] method that computes doses.
#'
#' @seealso [dose()], [probFunction()].
#'
#' @export
#' @example examples/Model-method-doseFunction.R
#'
setGeneric(
  name = "doseFunction",
  def = function(model, ...) {
    standardGeneric("doseFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-GeneralModel
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(x, ...) {
      dose(x = x, model = model, samples = samples, ...)
    }
  }
)

## ModelPseudo ----

#' @describeIn doseFunction
#'
#' @aliases doseFunction-ModelPseudo
#' @export
#'
setMethod(
  f = "doseFunction",
  signature = "ModelPseudo",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(names(model_params), len = length(model_params), any.missing = FALSE, unique = TRUE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn doseFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases doseFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "doseFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ", grade, ", a parameter named 'alpha", grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(x) {
      dose(x = x, model = model, samples = samples, grade = grade)
    }
  }
)

# probFunction ----

## generic ----

#' Getting the Prob Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns a [prob()] function that computes the toxicity
#' probabilities for a given dose level, based on the model specific parameters.
#'
#' @param model (`GeneralModel` or `ModelTox`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [prob()] function that computes toxicity probabilities.
#'
#' @seealso [prob()], [doseFunction()].
#'
#' @export
#' @example examples/Model-method-probFunction.R
#'
setGeneric(
  name = "probFunction",
  def = function(model, ...) {
    standardGeneric("probFunction")
  },
  valueClass = "function"
)

## GeneralModel ----

#' @describeIn probFunction
#'
#' @aliases probFunction-GeneralModel
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "GeneralModel",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_subset(names(model_params), model@sample, empty.ok = FALSE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose, ...) {
      prob(dose = dose, model = model, samples = samples, ...)
    }
  }
)

## ModelTox ----

#' @describeIn probFunction
#'
#' @aliases probFunction-ModelTox
#' @export
#'
setMethod(
  f = "probFunction",
  signature = "ModelTox",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(names(model_params), len = length(model_params), any.missing = FALSE, unique = TRUE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples)
    }
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn probFunction
#'
#' @param grade (`integer`)\cr the toxicity grade for which the dose function is
#' required
#'
#' @aliases probFunction-LogisticLogNormalOrdinal
#' @example examples/Model-method-probFunctionLogisticLogNormalOrdinal.R
#' @export
setMethod(
  f = "probFunction",
  signature = "LogisticLogNormalOrdinal",
  definition = function(model, grade, ...) {
    model_params <- list(...)
    assert_character(
      names(model_params),
      len = length(model_params),
      any.missing = FALSE,
      unique = TRUE
    )
    assert_integer(grade, lower = 1, len = 1)
    coll <- makeAssertCollection()
    if (!(paste0("alpha", grade) %in% names(model_params))) {
      coll$push(
        paste0(
          "Since grade = ", grade, ", a parameter named 'alpha", grade,
          "' must appear the call"
        )
      )
    }
    reportAssertions(coll)
    # Create dummy intercept columns if necessary
    for (g in seq_along(grade)) {
      if (!(paste0("alpha", g) %in% names(model_params))) {
        model_params[[paste0("alpha", g)]] <- rep(0, length(model_params[[1]]))
      }
    }

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = length(model_params[[1]]))
    )
    function(dose) {
      prob(dose = dose, model = model, samples = samples, grade = grade)
    }
  }
)


# efficacyFunction ----

## generic ----

#' Getting the Efficacy Function for a Given Model Type
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A function that returns an [efficacy()] function that computes expected
#' efficacy for a given dose level, based on the model specific parameters.
#'
#' @param model (`ModelEff`)\cr the model.
#' @param ... model specific parameters.
#'
#' @return A [efficacy()] function that computes expected efficacy.
#'
#' @seealso [efficacy()].
#'
#' @export
#' @example examples/Model-method-efficacyFunction.R
#'
setGeneric(
  name = "efficacyFunction",
  def = function(model, ...) {
    standardGeneric("efficacyFunction")
  },
  valueClass = "function"
)

## ModelEff ----

#' @describeIn efficacyFunction
#'
#' @aliases efficacyFunction-ModelEff
#' @export
#'
setMethod(
  f = "efficacyFunction",
  signature = "ModelEff",
  definition = function(model, ...) {
    model_params <- list(...)
    assert_character(names(model_params), len = length(model_params), any.missing = FALSE, unique = TRUE)

    samples <- Samples(
      data = model_params,
      options = McmcOptions(samples = NROW(model_params[[1]]))
    )
    function(dose) {
      efficacy(dose = dose, model = model, samples = samples)
    }
  }
)

# dose ----

## generic ----

#' Computing the Doses for a given independent variable, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the dose reaching a specific target value of a
#' given variable that dose depends on. The meaning of this variable depends
#' on the type of the model. For instance, for single agent dose escalation
#' model or pseudo DLE (dose-limiting events)/toxicity model, this variable
#' represents the a probability of the occurrence of a DLE. For efficacy models,
#' it represents expected efficacy.
#' The doses are computed based on the samples of the model parameters (samples).
#'
#' @details The `dose()` function computes the doses corresponding to a value of
#'   a given independent variable, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `dose()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [dose()] and [prob()] methods are the inverse of each other, for
#'   all [dose()] methods for which its first argument, i.e. a given independent
#'   variable that dose depends on, represents toxicity probability.
#'
#' @param x (`proportion` or `numeric`)\cr a value of an independent variable
#'   on which dose depends.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `x` must have the same size
#'   as the sample.
#' @param model (`GeneralModel` or `ModelPseudo`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute the resulting doses. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `number` or `numeric` vector with the doses.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `prob`.
#'
#' @seealso [doseFunction()], [prob()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-dose.R
#'
setGeneric(
  name = "dose",
  def = function(x, model, samples, ...) {
    standardGeneric("dose")
  },
  valueClass = "numeric"
)

## LogisticNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalOrdinal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' In the case of a `LogisticLogNormalOrdinal` model, `dose` returns only the
#' probability of toxicity at the given grade or higher
#'
#' @param grade (`integer`)\cr The toxicity grade for which probabilities are required
#'
#' @aliases dose-LogisticLogNormalOrdinal
#' @example examples/Model-method-doseLogisticLogNormalOrdinal.R
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(x, model, samples, grade) {
    assert_probabilities(x)
    assert_length(x, len = size(samples))
    assert_integer(grade, len = 1, lower = 1, upper = (length(names(samples@data)) - 1))
    a <- paste0("alpha", grade)
    assert_subset(c(a, "beta"), names(samples))

    alpha <- samples@data[[a]]
    beta <- samples@data$beta
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha) / beta) * ref_dose
  }
)

## LogisticLogNormalSub ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    ((logit(x) - alpha0) / alpha1) + ref_dose
  }
)

## ProbitLogNormal ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormal
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## ProbitLogNormalRel ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    ((probit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn dose method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the dose for the `mono` or for
#'   the `combo` arm.
#' @aliases dose-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(x, model, samples, group) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(x, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    exp((logit(x) - (alpha0 + is_combo * delta0)) / (alpha1 + is_combo * delta1)) * ref_dose
  }
)

## LogisticKadane ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadane
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(x, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * (logit(x) - logit(rho0)) + xmin * (logit(theta) - logit(x))
    num / (logit(theta) - logit(rho0))
  }
)

## LogisticNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(x, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    exp((logit(x) - alpha0) / alpha1) * ref_dose
  }
)

## LogisticLogNormalMixture ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    stop("not implemented")
  }
)

## DualEndpoint ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-DualEndpoint
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("betaZ", names(samples))
    assert_length(x, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    dose_temp <- (qnorm(x) - betaZ[, 1]) / betaZ[, 2]
    if (model@use_log_dose) {
      exp(dose_temp) * ref_dose
    } else {
      dose_temp * ref_dose
    }
  }
)

## LogisticIndepBeta ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'
#' @aliases dose-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(x, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- (log(x / (1 - x)) - phi1) / phi2
    exp(log_dose)
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_probabilities(x)
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(data = model_params, options = McmcOptions(samples = nsamples))
    assert_length(x, len = nsamples)

    dose(x, model, samples)
  }
)

## Effloglog-noSamples ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`).
#'   All model parameters (except `x`) should be present in the `model` object.
#'
#' @aliases dose-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(x, model) {
    assert_numeric(x, min.len = 1L, any.missing = FALSE, finite = TRUE)
    theta1 <- model@theta1
    theta2 <- model@theta2
    constant <- model@const
    assert_scalar(theta1)
    assert_scalar(theta2)
    assert_scalar(constant)

    exp(exp((x - theta1) / theta2)) - constant
  }
)

## EffFlexi ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLE (`x`). For this method `x` must
#'   be a scalar.
#'
#' @aliases dose-EffFlexi
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_number(x)
    assert_subset("ExpEff", names(samples))

    samples_efficacy <- samples@data$ExpEff
    dose_grid <- model@data@doseGrid

    # Find dose level for a given expected efficacy level using linear interpolation.
    apply(samples_efficacy, 1, function(se) {
      se_leq_x <- se <= x
      dose_level0 <- max(which(se_leq_x))
      dose_level1 <- min(which(!se_leq_x))
      eff0 <- se[dose_level0]
      eff1 <- se[dose_level1]
      dose0 <- dose_grid[dose_level0]
      dose1 <- dose_grid[dose_level1]
      dose0 + (dose1 - dose0) * ((x - eff0) / (eff1 - eff0))
    })
  }
)

## OneParLogNormalPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("alpha", names(samples))
    assert_length(x, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun_inv <- model@skel_fun_inv
    skel_fun_inv(x^(1 / exp(alpha)))
  }
)

## OneParExpPrior ----

#' @describeIn dose compute the dose level reaching a specific target
#'   probability of the occurrence of a DLT (`x`).
#'
#' @aliases dose-OneParExpPrior
#' @export
#'
setMethod(
  f = "dose",
  signature = signature(
    x = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(x, model, samples) {
    assert_probabilities(x)
    assert_subset("theta", names(samples))
    assert_length(x, len = size(samples))

    theta <- samples@data$theta
    skel_fun_inv <- model@skel_fun_inv
    assert_numeric(theta, lower = .Machine$double.xmin, finite = TRUE)
    skel_fun_inv(x^(1 / theta))
  }
)

# prob ----

## generic ----

#' Computing Toxicity Probabilities for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the probability of the occurrence of a DLE at a
#' specified dose level, based on the model parameters (samples).
#'
#' @details The `prob()` function computes the probability of toxicity for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `prob()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @note The [prob()] and [dose()] functions are the inverse of
#'   each other, for all [dose()] methods for which its first argument, i.e. a
#'   given independent variable that dose depends on, represents toxicity
#'   probability.
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`GeneralModel` or `ModelTox`)\cr the model for single agent
#'   dose escalation or pseudo DLE (dose-limiting events)/toxicity model.
#' @param samples (`Samples`)\cr the samples of model's parameters that will be
#'   used to compute toxicity probabilities. Can also be missing for some models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `proportion` or `numeric` vector with the toxicity probabilities.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.  In the
#'   case of `LogisticLogNormalOrdinal`, the probabilities relate to toxicities
#'   of  grade given by `grade`.
#'
#' @seealso [probFunction()], [dose()], [efficacy()].
#'
#' @export
#' @example examples/Model-method-prob.R
#'
setGeneric(
  name = "prob",
  def = function(dose, model, samples, ...) {
    standardGeneric("prob")
  },
  valueClass = c("numeric", "list")
)

## LogisticNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalSub ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalSub
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalSub",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- model@ref_dose
    plogis(alpha0 + alpha1 * (dose - ref_dose))
  }
)

## ProbitLogNormal ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## ProbitLogNormalRel ----

#' @describeIn prob
#'
#' @aliases prob-ProbitLogNormalRel
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "ProbitLogNormalRel",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    pnorm(alpha0 + alpha1 * (dose / ref_dose))
  }
)

## LogisticLogNormalGrouped ----

#' @describeIn prob method for [`LogisticLogNormalGrouped`] which needs `group`
#'   argument in addition.
#' @param group (`character` or `factor`)\cr for [`LogisticLogNormalGrouped`],
#'   indicating whether to calculate the probability for the `mono` or for
#'   the `combo` arm.
#' @aliases prob-LogisticLogNormalGrouped
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalGrouped",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, group, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "delta0", "alpha1", "delta1"), names(samples))
    assert_length(dose, len = size(samples))
    assert_multi_class(group, c("character", "factor"))
    assert_subset(as.character(group), choices = c("mono", "combo"))
    assert_length(group, len = size(samples))

    alpha0 <- samples@data$alpha0
    delta0 <- samples@data$delta0
    alpha1 <- samples@data$alpha1
    delta1 <- samples@data$delta1
    ref_dose <- as.numeric(model@ref_dose)
    is_combo <- as.integer(group == "combo")
    plogis((alpha0 + is_combo * delta0) + (alpha1 + is_combo * delta1) * log(dose / ref_dose))
  }
)

## LogisticKadane ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadane
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadane",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * logit(rho0) - xmin * logit(theta) + (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticKadaneBetaGamma ----

#' @describeIn prob
#'
#' @aliases prob-LogisticKadaneBetaGamma
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticKadaneBetaGamma",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("rho0", "gamma"), names(samples))
    assert_length(dose, len = size(samples))

    rho0 <- samples@data$rho0
    gamma <- samples@data$gamma
    theta <- model@theta
    xmin <- model@xmin
    num <- gamma * logit(rho0) - xmin * logit(theta) + (logit(theta) - logit(rho0)) * dose
    plogis(num / (gamma - xmin))
  }
)

## LogisticNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticNormalFixedMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticNormalFixedMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticNormalFixedMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    ref_dose <- as.numeric(model@ref_dose)
    plogis(alpha0 + alpha1 * log(dose / ref_dose))
  }
)

## LogisticLogNormalMixture ----

#' @describeIn prob
#'
#' @aliases prob-LogisticLogNormalMixture
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalMixture",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("alpha0", "alpha1"), names(samples))
    assert_length(dose, len = size(samples))

    alpha0 <- samples@data$alpha0
    alpha1 <- samples@data$alpha1
    comp <- samples@data$comp
    ref_dose <- as.numeric(model@ref_dose)
    sel <- cbind(seq_along(comp), comp)
    plogis(alpha0[sel] + alpha1[sel] * log(dose / ref_dose))
  }
)

## DualEndpoint ----

#' @describeIn prob
#'
#' @aliases prob-DualEndpoint
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("betaZ", names(samples))
    assert_length(dose, len = size(samples))

    betaZ <- samples@data$betaZ
    ref_dose <- as.numeric(model@ref_dose)
    stand_dose <- if (model@use_log_dose) {
      log(dose / ref_dose)
    } else {
      dose / ref_dose
    }
    pnorm(betaZ[, 1] + betaZ[, 2] * stand_dose)
  }
)

## LogisticIndepBeta ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the samples of [`LogisticIndepBeta`] model
#' parameters.
#'
#' @aliases prob-LogisticIndepBeta
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("phi1", "phi2"), names(samples))
    assert_length(dose, len = size(samples))

    phi1 <- samples@data$phi1
    phi2 <- samples@data$phi2
    log_dose <- log(dose)
    exp(phi1 + phi2 * log_dose) / (1 + exp(phi1 + phi2 * log_dose))
  }
)

## LogisticIndepBeta-noSamples ----

#' @describeIn prob compute toxicity probabilities of the occurrence of a DLE at
#' a specified dose level, based on the [`LogisticIndepBeta`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases prob-LogisticIndepBeta-noSamples
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticIndepBeta",
    samples = "missing"
  ),
  definition = function(dose, model, ...) {
    model_params <- h_slots(model, c("phi1", "phi2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(data = model_params, options = McmcOptions(samples = nsamples))

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    prob(dose, model, samples)
  }
)

## OneParLogNormalPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParLogNormalPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParLogNormalPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("alpha", names(samples))
    assert_length(dose, len = size(samples))

    alpha <- samples@data$alpha
    skel_fun <- model@skel_fun
    skel_fun(dose)^exp(alpha)
  }
)

## OneParExpPrior ----

#' @describeIn prob
#'
#' @aliases prob-OneParExpPrior
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "OneParExpPrior",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset("theta", names(samples))
    assert_length(dose, len = size(samples))

    theta <- samples@data$theta
    skel_fun <- model@skel_fun
    skel_fun(dose)^theta
  }
)

## LogisticLogNormalOrdinal ----

#' Calculate a grade-specific probability of toxicity for a given dose.
#' @describeIn prob
#'
#' @param grade (`integer` or `integer_vector`)\cr The toxicity grade for which probabilities are required
#' @param cumulative (`flag`)\cr Should the returned probability be cumulative
#' (the default) or grade-specific?
#' @aliases prob-LogisticLogNormalOrdinal
#' @export
#'
setMethod(
  f = "prob",
  signature = signature(
    dose = "numeric",
    model = "LogisticLogNormalOrdinal",
    samples = "Samples"
  ),
  definition = function(dose, model, samples, grade, cumulative = TRUE, ...) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_integer(
      grade,
      min.len = 1,
      max.len = length(model@params@mean) - 1,
      lower = 0,
      upper = length(model@params@mean) - 1
    )
    assert_subset(
      names(samples),
      c(paste0("alpha", 0:(length(model@params@mean) - 1)), "beta")
    )
    assert_length(dose, len = size(samples))
    assert_flag(cumulative)

    rv <- lapply(
      grade,
      function(g) {
        alpha <- samples@data[[paste0("alpha", g)]]
        beta <- samples@data$beta
        ref_dose <- as.numeric(model@ref_dose)

        cumulative_prob <- plogis(alpha + beta * log(dose / ref_dose))
        if (cumulative | g == as.integer(length(model@params@mean) - 1)) {
          return(cumulative_prob)
        }

        # Calculate grade-specific probabilities
        alpha0 <- samples@data[[paste0("alpha", g + 1)]]
        grade_prob <- cumulative_prob - plogis(alpha0 + beta * log(dose / ref_dose))
        return(grade_prob)
      }
    )
    if (length(rv) == 1) {
      return(rv[[1]])
    }
    names(rv) <- as.character(grade)
    return(rv)
  }
)

# efficacy ----

## generic ----

#' Computing Expected Efficacy for a Given Dose, Model and Samples
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that computes the value of expected efficacy at a specified dose
#' level, based on the model specific parameters. The model parameters (samples)
#' are obtained based on prior specified in form of pseudo data combined with
#' observed responses (if any).
#'
#' @details The `efficacy()` function computes the expected efficacy for given
#'   doses, using samples of the model parameter(s).
#'   If you work with multivariate model parameters, then assume that your model
#'   specific `efficacy()` method receives a samples matrix where the rows
#'   correspond to the sampling index, i.e. the layout is then
#'   `nSamples x dimParameter`.
#'
#' @param dose (`numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when `samples` is not missing: vectors
#'   of size 1 will be recycled to the size of the sample
#'   (i.e. `size(samples)`). Otherwise, `dose` must have the same
#'   size as the sample.
#' @param model (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... model specific parameters when `samples` are not used.
#'
#' @return A `numeric` vector with the values of expected efficacy.
#'   If non-scalar `samples` were used, then every element in the returned vector
#'   corresponds to one element of a sample. Hence, in this case, the output
#'   vector is of the same length as the sample vector. If scalar `samples` were
#'   used or no `samples` were used, e.g. for pseudo DLE/toxicity `model`,
#'   then the output is of the same length as the length of the `dose`.
#'
#' @seealso [dose()], [prob()].
#'
#' @export
#' @example examples/Model-method-efficacy.R
setGeneric(
  name = "efficacy",
  def = function(dose, model, samples, ...) {
    standardGeneric("efficacy")
  },
  valueClass = "numeric"
)

## Effloglog ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`Effloglog`] model parameters.
#'
#' @aliases efficacy-Effloglog
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_subset(c("theta1", "theta2"), names(samples))
    assert_length(dose, len = size(samples))

    theta1 <- samples@data$theta1
    theta2 <- samples@data$theta2
    constant <- model@const
    theta1 + theta2 * log(log(dose + constant))
  }
)

## Effloglog-noSamples ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the [`Effloglog`] model parameters.
#' All model parameters (except `dose`) should be present in the `model` object.
#'
#' @aliases efficacy-Effloglog-noSamples
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "Effloglog",
    samples = "missing"
  ),
  definition = function(dose, model) {
    model_params <- h_slots(model, c("theta1", "theta2"))
    nsamples <- length(model_params[[1]])
    samples <- Samples(data = model_params, options = McmcOptions(samples = nsamples))

    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_length(dose, len = nsamples)

    efficacy(dose, model, samples)
  }
)

## EffFlexi ----

#' @describeIn efficacy compute the expected efficacy at a specified dose level,
#' based on the samples of [`EffFlexi`] model parameters. If a given dose in
#' the `dose` vector is from outside of the dose grid range, the `NA_real` is
#' returned for this dose and the warning is thrown.
#'
#' @aliases efficacy-EffFlexi
#' @export
#'
setMethod(
  f = "efficacy",
  signature = signature(
    dose = "numeric",
    model = "EffFlexi",
    samples = "Samples"
  ),
  definition = function(dose, model, samples) {
    n_samples <- size(samples)
    assert_numeric(dose, lower = 0L, any.missing = FALSE, min.len = 1L)
    assert_true(model@data@nGrid >= 1L)
    assert_subset("ExpEff", names(samples))
    assert_length(dose, len = n_samples)

    dose_grid <- model@data@doseGrid
    dose_level <- match_within_tolerance(dose, dose_grid)
    dose[which(!is.na(dose_level))] <- dose_grid[stats::na.omit(dose_level)]

    # linear interpolation, NA for doses that are outside of the dose_grid range.
    samples_eff <- samples@data$ExpEff
    eff <- if (length(dose) == n_samples) {
      sapply(seq_len(n_samples), function(s) {
        stats::approx(dose_grid, samples_eff[s, ], xout = dose[s])$y
      })
    } else {
      eff <- apply(samples_eff, 1, function(s) {
        stats::approx(dose_grid, s, xout = dose)$y
      })
      as.vector(eff)
    }

    if (any(is.na(eff))) {
      warning(
        paste("At least one dose out of", paste(dose, collapse = ", "), "is outside of the dose grid range")
      )
    }
    eff
  }
)

# biomarker ----

## generic ----

#' Get the Biomarker Levels for a Given Dual-Endpoint Model, Given Dose Levels and Samples
#'
#' @details This function simply returns a specific columns (with the indices equal
#' to `xLevel`) of the biomarker samples matrix, which is included in the the
#' `samples` object.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' @param xLevel (`integer`)\cr the levels for the doses the patients have been
#'   given w.r.t dose grid. See [`Data`] for more details.
#' @param model (`DualEndpoint`)\cr the model.
#' @param samples (`Samples`)\cr the samples of model's parameters that store
#'   the value of biomarker levels for all doses on the dose grid.
#' @param ... not used.
#'
#' @return The biomarker levels.
#'
#' @export
#' @example examples/Model-method-biomarker.R
#'
setGeneric(
  name = "biomarker",
  def = function(xLevel, model, samples, ...) {
    standardGeneric("biomarker")
  },
  valueClass = c("numeric", "array")
)

## DualEndpoint ----

#' @describeIn biomarker
#'
#' @aliases biomarker-DualEndpoint
#' @export
#'
setMethod(
  f = "biomarker",
  signature = signature(
    xLevel = "integer",
    model = "DualEndpoint",
    samples = "Samples"
  ),
  def = function(xLevel, model, samples, ...) {
    assert_integer(
      xLevel,
      lower = 1,
      upper = ncol(samples@data$betaW),
      any.missing = FALSE,
      min.len = 1
    )

    samples@data$betaW[, xLevel]
  }
)

# gain ----

## generic ----

#' Compute Gain Values based on Pseudo DLE and a Pseudo Efficacy Models and
#' Using Optional Samples.
#'
#' @details This function computes the gain values for a given dose level,
#' pseudo DLE and Efficacy models as well as a given DLE and Efficacy samples.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param dose (`number` or `numeric`)\cr the dose which is targeted.
#'   The following recycling rule applies when samples are not missing: vectors
#'   of size 1 will be recycled to the size of the sample. Otherwise, `dose`
#'   must have the same size as the sample.
#' @param model_dle (`ModelTox`)\cr pseudo DLE (dose-limiting events)/toxicity
#'   model.
#' @param samples_dle (`Samples`)\cr the samples of model's
#'   parameters that will be used to compute toxicity probabilities. Can also be
#'   missing for some models.
#' @param model_eff (`ModelEff`)\cr the efficacy model with pseudo data prior.
#' @param samples_eff (`Samples`)\cr samples of model's parameters that will be
#'   used to compute expected efficacy values. Can also be missing for some
#'   models.
#' @param ... not used.
#'
#' @return The gain values.
#'
#' @export
#' @example examples/Model-method-gain.R
#'
setGeneric(
  name = "gain",
  def = function(dose, model_dle, samples_dle, model_eff, samples_eff, ...) {
    standardGeneric("gain")
  },
  valueClass = "numeric"
)

## ModelTox-ModelEff ----

#' @describeIn gain
#'
#' @aliases gain-ModelTox-ModelEff
#' @export
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "Samples",
    model_eff = "ModelEff",
    samples_eff = "Samples"
  ),
  definition = function(dose, model_dle, samples_dle, model_eff, samples_eff, ...) {
    dle <- prob(dose, model_dle, samples_dle)
    eff <- efficacy(dose, model_eff, samples_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

## ModelTox-ModelEff-noSamples----

#' @describeIn gain Compute the gain value for a given dose level, pseudo DLE
#'   and Efficacy models without DLE and the Efficacy samples.
#'
#' @aliases gain-ModelTox-Effloglog-noSamples
#' @export
#' @example examples/Model-method-gainNoSamples.R
#'
setMethod(
  f = "gain",
  signature = signature(
    dose = "numeric",
    model_dle = "ModelTox",
    samples_dle = "missing",
    model_eff = "Effloglog",
    samples_eff = "missing"
  ),
  definition = function(dose, model_dle, model_eff, ...) {
    dle <- prob(dose, model_dle)
    eff <- efficacy(dose, model_eff)
    assert_length(dle, len = length(eff))
    eff / (1 + (dle / (1 - dle)))
  }
)

# update ----

## ModelPseudo ----

#' Update method for the [`ModelPseudo`] model class. This is a method to update
#' the model class slots (estimates, parameters, variables and etc.), when the
#' new data (e.g. new observations of responses) are available. This method is
#' mostly used to obtain new modal estimates for pseudo model parameters.
#'
#' @param object (`ModelPseudo`)\cr the model to update.
#' @param data (`Data`)\cr all currently available of data.
#' @param ... not used.
#'
#' @return the new [`ModelPseudo`] class object.
#'
#' @aliases update-ModelPseudo
#' @export
#' @example examples/Model-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(
    object = "ModelPseudo"
  ),
  definition = function(object, data, ...) {
    assert_class(data, "Data")

    constructor_name <- class(object)
    arg_names <- setdiff(formalArgs(constructor_name), "data")
    do.call(
      constructor_name,
      c(h_slots(object, arg_names), list(data = data))
    )
  }
)

##' @include helpers.R
##' @include Model-class.R
NULL

# nolint start

##' Convert prior quantiles (lower, median, upper) to logistic (log)
##' normal model
##'
##' This function uses generalized simulated annealing to optimize
##' a \code{\linkS4class{LogisticNormal}} model to be as close as possible
##' to the given prior quantiles.
##'
##' @param dosegrid the dose grid
##' @param refDose the reference dose
##' @param lower the lower quantiles
##' @param median the medians
##' @param upper the upper quantiles
##' @param level the credible level of the (lower, upper) intervals (default:
##' 0.95)
##' @param logNormal use the log-normal prior? (not default) otherwise, the
##' normal prior for the logistic regression coefficients is used
##' @param parstart starting values for the parameters. By default, these
##' are determined from the medians supplied.
##' @param parlower lower bounds on the parameters (intercept alpha and the
##' slope beta, the corresponding standard deviations and the correlation.)
##' @param parupper upper bounds on the parameters
##' @param seed seed for random number generation
##' @param verbose be verbose? (default)
##' @param control additional options for the optimisation routine, see
##' \code{\link[GenSA]{GenSA}} for more details
##' @return a list with the best approximating \code{model}
##' (\code{\linkS4class{LogisticNormal}} or
##' \code{\linkS4class{LogisticLogNormal}}), the resulting \code{quantiles}, the
##' \code{required} quantiles and the \code{distance} to the required quantiles,
##' as well as the final \code{parameters} (which could be used for running the
##' algorithm a second time)
##'
##' @importFrom GenSA GenSA
##' @importFrom mvtnorm rmvnorm
##' @export
##' @keywords programming
Quantiles2LogisticNormal <- function(dosegrid,
                                     refDose,
                                     lower,
                                     median,
                                     upper,
                                     level = 0.95,
                                     logNormal = FALSE,
                                     parstart = NULL,
                                     parlower = c(-10, -10, 0, 0, -0.95),
                                     parupper = c(10, 10, 10, 10, 0.95),
                                     seed = 12345,
                                     verbose = TRUE,
                                     control =
                                       list(
                                         threshold.stop = 0.01,
                                         maxit = 50000,
                                         temperature = 50000,
                                         max.time = 600
                                       )) {
  ## extracts and checks
  nDoses <- length(dosegrid)

  assert_flag(logNormal)
  assert_flag(verbose)
  assert_probability(level, bounds_closed = FALSE)
  stopifnot(
    !is.unsorted(dosegrid, strictly = TRUE),
    ## the medians must be monotonically increasing:
    !is.unsorted(median),
    identical(length(lower), nDoses),
    identical(length(median), nDoses),
    identical(length(upper), nDoses),
    all(lower < median),
    all(upper > median),
    identical(length(parlower), 5L),
    identical(length(parupper), 5L),
    all(parlower < parstart),
    all(parstart < parupper)
  )

  ## put verbose argument in the control list
  control$verbose <- verbose

  ## parametrize in terms of the means for the intercept alpha and the
  ## (log) slope beta,
  ## the corresponding standard deviations and the correlation.
  ## Define start values for optimisation:
  startValues <-
    if (is.null(parstart)) {
      ## find approximate means for alpha and slope beta
      ## from fitting logistic model to medians:
      startAlphaBeta <-
        coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))

      ## overall starting values:
      c(
        meanAlpha =
          startAlphaBeta[1],
        meanBeta =
          if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2],
        sdAlpha =
          1,
        sdBeta =
          1,
        correlation =
          0
      )
    } else {
      parstart
    }

  ## what is the target function which we want to minimize?
  target <- function(param) {
    ## form the mean vector and covariance matrix
    mean <- param[1:2]
    cov <- matrix(
      c(
        param[3]^2,
        prod(param[3:5]),
        prod(param[3:5]),
        param[4]^2
      ),
      nrow = 2L, ncol = 2L
    )

    ## simulate from the corresponding normal distribution
    set.seed(seed)
    normalSamples <- mvtnorm::rmvnorm(
      n = 1e4L,
      mean = mean,
      sigma = cov
    )

    ## extract separate coefficients
    alphaSamples <- normalSamples[, 1L]
    betaSamples <- if (logNormal) exp(normalSamples[, 2L]) else normalSamples[, 2L]

    ## and compute resulting quantiles
    quants <- matrix(
      nrow = length(dosegrid),
      ncol = 3L
    )
    colnames(quants) <- c("lower", "median", "upper")

    ## process each dose after another:
    for (i in seq_along(dosegrid))
    {
      ## create samples of the probability
      probSamples <-
        plogis(alphaSamples + betaSamples * log(dosegrid[i] / refDose))

      ## compute lower, median and upper quantile
      quants[i, ] <-
        quantile(probSamples,
          probs = c((1 - level) / 2, 0.5, (1 + level) / 2)
        )
    }

    ## now we can compute the target value
    ret <- max(abs(quants - c(lower, median, upper)))
    return(structure(ret,
      mean = mean,
      cov = cov,
      quantiles = quants
    ))
  }

  set.seed(seed)
  ## now optimise the target
  genSAres <- GenSA::GenSA(
    par = startValues,
    fn = target,
    lower = parlower,
    upper = parupper,
    control = control
  )
  distance <- genSAres$value
  pars <- genSAres$par
  targetRes <- target(pars)

  ## and construct the model
  ret <-
    if (logNormal) {
      LogisticLogNormal(
        mean = attr(targetRes, "mean"),
        cov = attr(targetRes, "cov"),
        ref_dose = refDose
      )
    } else {
      LogisticNormal(
        mean = attr(targetRes, "mean"),
        cov = attr(targetRes, "cov"),
        ref_dose = refDose
      )
    }

  ## return it together with the resulting distance and the quantiles
  return(list(
    model = ret,
    parameters = pars,
    quantiles = attr(targetRes, "quantiles"),
    required = cbind(lower, median, upper),
    distance = distance
  ))
}

# nolint end

#' Helper for Minimal Informative Unimodal Beta Distribution
#'
#' As defined in Neuenschwander et al (2008), this function computes the
#' parameters of the minimal informative unimodal beta distribution, given the
#' request that the p-quantile should be q, i.e. `X ~ Be(a, b)` with
#' `Pr(X <= q) = p`.
#'
#' @param p (`number`)\cr the probability.
#' @param q (`number`)\cr the quantile.
#' @return A list with the two resulting beta parameters `a` and `b`.
#'
#' @keywords internal
h_get_min_inf_beta <- function(p, q) {
  assert_probability(p, bounds_closed = FALSE)
  assert_probability(q, bounds_closed = FALSE)

  if (q > p) {
    list(
      a = log(p) / log(q),
      b = 1
    )
  } else {
    list(
      a = 1,
      b = log(1 - p) / log(1 - q)
    )
  }
}

# nolint start

##' Construct a minimally informative prior
##'
##' This function constructs a minimally informative prior, which is captured in
##' a \code{\linkS4class{LogisticNormal}} (or
##' \code{\linkS4class{LogisticLogNormal}}) object.
##'
##' Based on the proposal by Neuenschwander et al (2008, Statistics in
##' Medicine), a minimally informative prior distribution is constructed. The
##' required key input is the minimum (\eqn{d_{1}} in the notation of the
##' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
##' grid supplied to this function. Then \code{threshmin} is the probability
##' threshold \eqn{q_{1}}, such that any probability of DLT larger than
##' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
##' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
##' \code{threshmax} is the probability threshold \eqn{q_{J}}, such that any
##' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
##' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
##' controlled with the arguments \code{probmin} and \code{probmax}, respectively.
##' Subsequently, for all doses supplied in the
##' \code{dosegrid} argument, beta distributions are set up from the assumption
##' that the prior medians are linear in log-dose on the logit scale, and
##' \code{\link{Quantiles2LogisticNormal}} is used to transform the resulting
##' quantiles into an approximating \code{\linkS4class{LogisticNormal}} (or
##' \code{\linkS4class{LogisticLogNormal}}) model. Note that the reference dose
##' is not required for these computations.
##'
##' @param dosegrid the dose grid
##' @param refDose the reference dose
##' @param threshmin Any toxicity probability above this threshold would
##' be very unlikely (see \code{probmin}) at the minimum dose (default: 0.2)
##' @param threshmax Any toxicity probability below this threshold would
##' be very unlikely (see \code{probmax}) at the maximum dose (default: 0.3)
##' @param probmin the prior probability of exceeding \code{threshmin} at the
##' minimum dose (default: 0.05)
##' @param probmax the prior probability of being below \code{threshmax} at the
##' maximum dose (default: 0.05)
##' @param \dots additional arguments for computations, see
##' \code{\link{Quantiles2LogisticNormal}}, e.g. \code{refDose} and
##' \code{logNormal=TRUE} to obtain a minimal informative log normal prior.
##' @return see \code{\link{Quantiles2LogisticNormal}}
##'
##' @example examples/MinimalInformative.R
##' @export
##' @keywords programming
MinimalInformative <- function(dosegrid,
                               refDose,
                               threshmin = 0.2,
                               threshmax = 0.3,
                               probmin = 0.05,
                               probmax = 0.05,
                               ...) {
  ## extracts and checks
  nDoses <- length(dosegrid)

  assert_probability(threshmin, bounds_closed = FALSE)
  assert_probability(threshmax, bounds_closed = FALSE)
  assert_probability(probmin, bounds_closed = FALSE)
  assert_probability(probmax, bounds_closed = FALSE)
  stopifnot(
    !is.unsorted(dosegrid, strictly = TRUE)
  )
  xmin <- dosegrid[1]
  xmax <- dosegrid[nDoses]

  ## derive the beta distributions at the lowest and highest dose
  betaAtMin <- h_get_min_inf_beta(
    q = threshmin,
    p = 1 - probmin
  )
  betaAtMax <- h_get_min_inf_beta(
    q = threshmax,
    p = probmax
  )

  ## get the medians of those beta distributions
  medianMin <- with(
    betaAtMin,
    qbeta(p = 0.5, a, b)
  )
  medianMax <- with(
    betaAtMax,
    qbeta(p = 0.5, a, b)
  )

  ## now determine the medians of all beta distributions
  beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
  alpha <- logit(medianMax) - beta * log(xmax / refDose)
  medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))

  ## finally for all doses calculate 95% credible interval bounds
  ## (lower and upper)
  lower <- upper <- dosegrid
  for (i in seq_along(dosegrid))
  {
    ## get min inf beta distribution
    thisMinBeta <- h_get_min_inf_beta(
      p = 0.5,
      q = medianDosegrid[i]
    )

    ## derive required quantiles
    lower[i] <- with(
      thisMinBeta,
      qbeta(p = 0.025, a, b)
    )
    upper[i] <- with(
      thisMinBeta,
      qbeta(p = 0.975, a, b)
    )
  }

  ## now go to Quantiles2LogisticNormal
  Quantiles2LogisticNormal(
    dosegrid = dosegrid,
    refDose = refDose,
    lower = lower,
    median = medianDosegrid,
    upper = upper,
    level = 0.95,
    ...
  )
}

# nolint end

#' Format a `doseGrid` for Printing
#'
#' @param grid (`numeric`)\cr the dose grid
#' @param units (`character`)\cr The units in which the values in `doseGrid` are
#' measured.  Appended to each value in `doseGrid` when `knit_print`ed.  The
#' default, `NA`, omits the units.
#' @return A character string containing the formatted dose grid.  If the grid
#' is `c(1, 2, 3)` and `units` is `"mg"`, the returned value is `"1 mg, 2 mg and 3 mg"`.
#' @keywords internal
h_get_formatted_dosegrid <- function(grid, units = NA) {
  assert_numeric(grid, lower = 0, min.len = 2, unique = TRUE, finite = TRUE, sorted = TRUE, any.missing = FALSE)
  assert_character(units, len = 1)

  n <- length(grid)
  if (is.na(units)) {
    units <- ""
  } else {
    units <- paste0(" ", units)
  }
  paste0(
    paste(
      lapply(grid[1:(n - 1)], paste0, sep = units),
      collapse = ", "
    ),
    " and ",
    grid[n],
    paste0(units, ".")
  )
}

#' Set Column Headers in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param param (`list`)\cr A list of the `...` parameters passed to `knit_print`
#' @param summarise (`flag`)\cr Is the object to be summarised (default) or listed?
#' @return A character vector of column names.
#' @noRd
h_knit_print_set_headers <- function(x, param, summarise, ...) {
  UseMethod("h_knit_print_set_headers")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.GeneralData <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "DLT?")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataDA <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataGrouped <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "Group", "Tox")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Group", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Group", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataParts <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Part", "Cohort", "Dose", "Tox")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_set_headers.DataOrdinal <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", paste0("Cat", 0:(length(x@yCategories) - 1)))
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", names(x@yCategories))
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", names(x@yCategories))
    }
  }
  param
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_set_headers
#' @noRd
h_knit_print_set_headers.DataDual <- function(x, param, summarise, ...) {
  if (!("col.names" %in% names(param))) {
    if (summarise == "none") {
      param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "W")
    } else if (summarise == "dose") {
      param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
    } else {
      param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
    }
  }
  param
}

#' Select Columns to Print in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param ... Not used at present.
#' @return A tidied version of `x`, containing only the selected columns.
#' @noRd
h_knit_print_select_columns <- function(x, ...) {
  UseMethod("h_knit_print_select_columns")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.GeneralData <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.Data <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataParts <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Part", "Cohort", "Dose", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataOrdinal <- function(x, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", tidyselect::starts_with("Cat"))
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataDA <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataGrouped <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Group", "Tox")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_select_columns
#' @noRd
h_knit_print_select_columns.DataDual <- function(x, param, summarise, ...) {
  x %>%
    tidy() %>%
    dplyr::select("ID", "Cohort", "Dose", "Tox", "W")
}

#' Summarise a `Data` Object by Dose or Cohort for Display in Custom `knit_print` Methods
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`ANY`)\cr object that will be printed
#' @param full_grid (`flag`)\cr Should the full grid be included or only those
#' doses with at least one evaluable participant?
#' @param ... Not used at present.
#' @return A tibble containing the summarised data
#' @noRd
h_knit_print_summarise <- function(x, summarise, full_grid, ...) {
  UseMethod("h_knit_print_summarise")
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.GeneralData <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data[[stringr::str_to_title(summarise)]]) %>%
    dplyr::summarise(
      N = dplyr::n(),
      ToxCount = sum(Tox)
    )
  if (full_grid && summarise == "dose") {
    xTidy <- xTidy %>%
      tidyr::complete(
        Dose = x@doseGrid,
        fill = list(ToxCount = 0, N = 0)
      )
  }
  xTidy
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.DataOrdinal <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data$Dose) %>%
    dplyr::summarise(
      N = dplyr::n(),
      dplyr::across(tidyselect::starts_with("Cat"), sum)
    )
  if (full_grid && summarise == "dose") {
    replace_list <- as.list(
      c(
        "N",
        names(xTidy)[which(stringr::str_detect(names(xTidy), "Cat\\d+"))]
      )
    )
    # Create a list whose names are the columns in which we need to replace NAs
    # and whose values are 0
    names(replace_list) <- sapply(replace_list, \(x) x)
    replace_list <- lapply(replace_list, \(x) 0)
    # Expand the tibble and do the replacement
    xTidy <- tidyr::expand_grid(Dose = x@doseGrid) %>%
      dplyr::left_join(xTidy, by = "Dose") %>%
      tidyr::replace_na(replace_list)
  }
  xTidy
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print_summarise
#' @noRd
h_knit_print_summarise.DataGrouped <- function(x, summarise, full_grid, ...) {
  xTidy <- x %>% tidy()
  xTidy <- xTidy %>%
    dplyr::group_by(.data[[stringr::str_to_title(summarise)]], .data$Group) %>%
    dplyr::summarise(
      N = dplyr::n(),
      ToxCount = sum(Tox)
    )
  if (full_grid && summarise == "dose") {
    xTidy <- tidyr::expand_grid(
      Dose = x@doseGrid,
      Group = c("mono", "combo")
    ) %>%
      dplyr::left_join(xTidy, by = c("Dose", "Group")) %>%
      tidyr::replace_na(list(N = 0, ToxCount = 0))
  }
  xTidy
}

#' Print a `GeneralData` Object in a Markdown or Quarto Chunk
#'
#' @param labels (`character`)\cr How to describe the participants in the trial.
#' See Usage Notes below.
#' @param full_grid (`flag`)\cr Should the full dose grid appear in the output table
#' or simply those doses for whom at least one evaluable participant is available?
#' Ignored unless `summarise == "dose"`.
#' @param summarise (`character`)\cr How to summarise the observed data.  The default,
#' `"none"`, lists observed data at the participant level.  `"dose"` presents
#' participant counts by dose and `"cohort"` by cohort.
#' @param summarize (`character`)\cr Synonym for `summarise`
#' @param format_func (`function`)\cr The function used to format the participant table.
#' The default applies no formatting.  Obvious alternatives include `kableExtra::kable_styling`.
#' @param ... passed to [knitr::kable()]
#' @section Usage Notes:
#' `labels` describes the trial's participants.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single participant and the second describes all other
#' situations.  If of length 1, the character `s` is appended to the value
#' when the number of participants is not 1.
#' The default values of `col.names` and `caption` vary depending on the summary
#' requested. The default values can be overridden by passing `col.names` and
#' `caption` in the function call.
#'
#' @inheritParams h_get_formatted_dosegrid
#' @export
#' @rdname knit_print
knit_print.GeneralData <- function(
    x, ..., asis = TRUE,
    labels = c("participant", "participants"),
    full_grid = FALSE,
    summarise = c("none", "dose", "cohort"),
    summarize = summarise,
    units = NA,
    format_func = function(x) x) {
  # Validate
  assert_character(labels, max.len = 2, any.missing = FALSE)
  assert_flag(asis)
  assert_flag(full_grid)
  assert_function(format_func)
  summarise <- match.arg(summarise)
  summarize <- match.arg(summarize)

  if (is.na(summarise) || is.null(summarise)) {
    summarise <- summarize
  }
  assert_choice(summarise, c("none", "dose", "cohort"))
  # Initialise
  if (length(labels) == 1) {
    labels[2] <- paste0(labels[1], "s")
  }
  param <- list(...)

  # Execute
  param <- h_knit_print_set_headers(x, param, summarise, ...)
  if (summarise == "none") {
    if (!("caption" %in% names(param))) {
      param[["caption"]] <- paste("Evaluable", labels[2], "to-date")
    }
    xTidy <- h_knit_print_select_columns(x)
  } else {
    xTidy <- h_knit_print_summarise(x, summarise, full_grid)
    if (!("caption" %in% names(param))) {
      param[["caption"]] <- paste0("Summarised by ", summarise)
    }
  }
  param[["x"]] <- xTidy
  rv <- if (length(x@x) > 0) {
    paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
  } else {
    paste("No", labels[2], "are yet evaluable.\n\n")
  }
  rv <- paste0(
    rv,
    paste0(
      "\n\nThe dose grid is ",
      h_get_formatted_dosegrid(
        grid = x@doseGrid,
        units = units
      ),
      ""
    ),
    collpase = "<br>"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @export
#' @rdname knit_print
knit_print.DataParts <- function(
    x, ..., asis = TRUE,
    labels = c("participant", "participants"),
    full_grid = FALSE,
    summarise = c("none", "dose", "cohort"),
    summarize = summarise,
    units = NA,
    format_func = function(x) x) {
  rv <- NextMethod()
  rv <- paste0(
    rv,
    paste0(
      "\n\nThe part 1 ladder is ",
      h_get_formatted_dosegrid(x@part1Ladder, units)
    ),
    paste0("\n\nThe next part is Part ", x@nextPart, ".")
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @include helpers.R
#' @include Data-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralData-class ----

#' `GeneralData`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`GeneralData`] is a class for general data input.
#'
#' @slot ID (`integer`)\cr unique patient IDs.
#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#' @slot nObs (`integer`)\cr number of observations, a single value.
#'
#' @aliases GeneralData
#' @export
#'
.GeneralData <- setClass(
  Class = "GeneralData",
  slots = c(
    ID = "integer",
    cohort = "integer",
    nObs = "integer"
  ),
  prototype = prototype(
    ID = integer(),
    cohort = integer(),
    nObs = 0L
  ),
  contains = "CrmPackClass",
  validity = v_general_data
)

## default constructor ----

#' @rdname GeneralData-class
#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
#' @export
.DefaultDataGeneral <- function() {
  stop(paste0("Class DataGeneral cannot be instantiated directly.  Please use one of its subclasses instead."))
}

# Data ----

## class ----

#' `Data`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Data`] is a class for the data input.
#' It inherits from [`GeneralData`].
#'
#' @slot x (`numeric`)\cr the doses for the patients.
#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
#'   i.e. the dose grid.
#' @slot nGrid (`integer`)\cr number of gridpoints.
#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
#'   w.r.t `doseGrid`.
#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
#'   in the `doseGrid`is considered as PLACEBO.
#'
#' @aliases Data
#' @export
#'
.Data <- setClass(
  Class = "Data",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    placebo = FALSE
  ),
  validity = v_data
)

## constructor ----

#' @rdname Data-class
#'
#' @details The `cohort` can be missing if and only if `placebo` is equal to
#'   `FALSE`.
#'
#' @note `ID` and `cohort` can be missing. Then a message will be issued
#'   and the variables will be filled with default IDs and best guesses cohort,
#'   i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
#'
#' @param x (`numeric`)\cr the doses for the patients.
#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param ID (`integer`)\cr unique patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param doseGrid (`numeric`)\cr all possible doses.
#' @param placebo (`flag`)\cr if `TRUE` the first dose level
#'   in the `doseGrid` is considered as placebo.
#' @param ... not used.
#'
#' @export
#' @example examples/Data-class.R
#'
Data <- function(x = numeric(),
                 y = integer(),
                 ID = integer(),
                 cohort = integer(),
                 doseGrid = numeric(),
                 placebo = FALSE,
                 ...) {
  assert_numeric(x)
  assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
  assert_integerish(ID, unique = TRUE, any.missing = FALSE)
  assert_integerish(cohort)
  assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  assert_flag(placebo)

  doseGrid <- sort(doseGrid)
  assert_subset(x, doseGrid)

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .Data(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = as.numeric(doseGrid),
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x, doseGrid),
    placebo = placebo
  )
}

## default constructor ----

#' @rdname Data-class
#' @note Typically, end users will not use the `.DefaultData()` function.
#' @export
.DefaultData <- function() {
  Data(
    doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
    ID = 1L:3L,
    cohort = 1L:3L,
    x = c(1, 3, 5),
    y = rep(0L, 3)
  )
}

# DataDual ----

## class ----

#' `DataDual`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDual`] is a class for the dual endpoint data.
#' It inherits from [`Data`] and it contains additional biomarker information.
#'
#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
#'
#' @aliases DataDual
#' @export
#'
.DataDual <- setClass(
  Class = "DataDual",
  slots = c(w = "numeric"),
  prototype = prototype(w = numeric()),
  contains = "Data",
  validity = v_data_dual
)

## constructor ----

#' @rdname DataDual-class
#'
#' @param w (`numeric`)\cr the continuous vector of biomarker values.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDual.R
#'
DataDual <- function(w = numeric(),
                     ...) {
  d <- Data(...)
  .DataDual(d, w = w)
}


## default constructor ----

#' @rdname DataDual-class
#' @note Typically, end users will not use the `.DefaultDataDual()` function.
#' @export
.DefaultDataDual <- function() {
  set.seed(1230)
  DataDual(
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 0, 0, 0, 0, 1, 0),
    w = rnorm(8),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataParts ----

## class ----

#' `DataParts`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataParts`] is a class for the data with two study parts.
#' It inherits from [`Data`] and it contains additional information
#' on the two study parts.
#'
#' @slot part (`integer`)\cr which part does each of the patients belong to?
#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
#'   part 1? This shall be an ordered subset of the `doseGrid`.
#'
#' @aliases DataParts
#' @export
#'
.DataParts <- setClass(
  Class = "DataParts",
  slots = c(
    part = "integer",
    nextPart = "integer",
    part1Ladder = "numeric"
  ),
  prototype = prototype(
    part = integer(),
    nextPart = 1L,
    part1Ladder = numeric()
  ),
  contains = "Data",
  validity = v_data_parts
)

## constructor ----

#' @rdname DataParts-class
#'
#' @param part (`integer`)\cr which part does each of the patients belong to?
#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
#'   This shall be an ordered subset of the `doseGrid`.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataParts.R
#'
DataParts <- function(part = integer(),
                      nextPart = 1L,
                      part1Ladder = numeric(),
                      ...) {
  d <- Data(...)
  .DataParts(
    d,
    part = part,
    nextPart = nextPart,
    part1Ladder = part1Ladder
  )
}

## default constructor ----

#' @rdname DataParts-class
#' @note Typically, end users will not use the `.DefaultDataParts()` function.
#' @export
.DefaultDataParts <- function() {
  DataParts(
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1:3,
    cohort = 1:3,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    part = c(1L, 1L, 1L),
    nextPart = 1L,
    part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
  )
}


# DataMixture ----

## class ----

#' `DataMixture`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataMixture`] is a class for the data with mixture sharing.
#' It inherits from [`Data`] and it contains additional information
#' on the mixture sharing.
#'
#' @slot xshare (`numeric`)\cr the doses for the share patients.
#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients.
#' @slot nObsshare (`count`)\cr number of share patients.
#'
#' @aliases DataMixture
#' @export
#'
.DataMixture <- setClass(
  Class = "DataMixture",
  slots = c(
    xshare = "numeric",
    yshare = "integer",
    nObsshare = "integer"
  ),
  prototype = prototype(
    xshare = numeric(),
    yshare = integer(),
    nObsshare = 0L
  ),
  contains = "Data",
  validity = v_data_mixture
)

## constructor ----

#' @rdname DataMixture-class
#'
#' @param xshare (`numeric`)\cr the doses for the share patients.
#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
#'   for the share patients. You can also supply `numeric` vectors,
#'   but these will then be converted to `integer` internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataMixture.R
#'
DataMixture <- function(xshare = numeric(),
                        yshare = integer(),
                        ...) {
  d <- Data(...)
  assert_integerish(yshare)
  assert_numeric(xshare)
  .DataMixture(
    d,
    xshare = as.numeric(xshare),
    yshare = as.integer(yshare),
    nObsshare = length(xshare)
  )
}

## default constructor ----

#' @rdname DataMixture-class
#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
#' @export
.DefaultDataMixture <- function() {
  DataMixture(
    xshare = c(12, 14, 16, 18.0),
    yshare = c(0L, 1L, 1L, 1L),
    nObsshare = 4L,
    x = c(0.1, 0.5, 1.5),
    y = c(0, 0, 0),
    ID = 1L:3L,
    cohort = 1L:3L,
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
  )
}


# DataDA ----

## class ----

#' `DataDA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataDA`] is a class for the time-to-DLT augmented data.
#' It inherits from [`Data`] and it contains additional DLT free survival times.
#'
#' @note `survival time` here refers to the time period for which the subject
#'   did not experience any DLT, and is not referring to deaths.
#'
#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#' @slot Tmax (`number`)\cr the DLT observation period.
#'
#' @aliases DataDA
#' @export
#'
.DataDA <- setClass(
  Class = "DataDA",
  slots = c(
    u = "numeric",
    t0 = "numeric",
    Tmax = "numeric"
  ),
  prototype = prototype(
    u = numeric(),
    t0 = numeric(),
    Tmax = 0 + .Machine$double.xmin
  ),
  contains = "Data",
  validity = v_data_da
)

## constructor ----

#' @rdname DataDA-class
#'
#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
#'   Non-negative values sorted in ascending order.
#'   Default to vector of 0s of length equal to length of `u`.
#' @param Tmax (`number`)\cr the DLT observation period.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataDA.R
#'
DataDA <- function(u = numeric(),
                   t0 = numeric(length(u)),
                   Tmax = 0 + .Machine$double.xmin,
                   ...) {
  d <- Data(...)
  .DataDA(
    d,
    u = as.numeric(u),
    t0 = as.numeric(t0),
    Tmax = as.numeric(Tmax)
  )
}

## default constructor ----

#' @rdname DataDA-class
#' @note Typically, end users will not use the `.DefaultDataDA()` function.
#' @export
.DefaultDataDA <- function() {
  DataDA(
    u = c(42, 30, 15, 5, 20, 25, 30, 60),
    t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
    Tmax = 60,
    x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
    y = c(0, 0, 1, 1, 0, 0, 1, 0),
    doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    ID = 1L:8L,
    cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
  )
}

# DataOrdinal ----

## class ----

#' `DataOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DataOrdinal`] is a class for ordinal toxicity data.
#' It inherits from [`GeneralData`] and it describes toxicity responses on an
#' ordinal rather than binary scale.
#'
#' @note This class has been implemented as a sibling of the existing `Data` class
#' (rather than as a parent or child) to minimise the risk of unintended side
#' effects on existing classes and methods.
#'
#' The default setting for the `yCategories` slot replicates the behaviour
#' of the existing `Data` class.
#'
#' @aliases DataOrdinal
#' @export
.DataOrdinal <- setClass(
  Class = "DataOrdinal",
  contains = "GeneralData",
  slots = c(
    x = "numeric",
    y = "integer",
    doseGrid = "numeric",
    nGrid = "integer",
    xLevel = "integer",
    yCategories = "integer",
    placebo = "logical"
  ),
  prototype = prototype(
    x = numeric(),
    y = integer(),
    doseGrid = numeric(),
    nGrid = 0L,
    xLevel = integer(),
    yCategories = c("No DLT" = 0L, "DLT" = 1L),
    placebo = FALSE
  ),
  validity = v_data_ordinal
)

## constructor ----

#' @rdname DataOrdinal-class
#' @param yCategories (named `integer`)\cr the names and codes for the
#' toxicity categories used in the data.  Category labels are taken from the
#' names of the vector.  The names of the vector must be unique and its values
#' must be sorted and take the values 0, 1, 2, ...
#' @inheritParams Data
#' @inherit Data details note params
#' @example examples/Data-class-DataOrdinal.R
#' @export
DataOrdinal <- function(x = numeric(),
                        y = integer(),
                        ID = integer(),
                        cohort = integer(),
                        doseGrid = numeric(),
                        placebo = FALSE,
                        yCategories = c("No DLT" = 0L, "DLT" = 1L),
                        ...) {
  assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
  assert_integerish(
    yCategories,
    any.missing = FALSE,
    unique = TRUE,
    names = "unique",
    min.len = 2
  )
  assert_flag(placebo)

  doseGrid <- as.numeric(sort(doseGrid))

  if (length(ID) == 0 && length(x) > 0) {
    message("Used default patient IDs!")
    ID <- seq_along(x)
  } else {
    assert_integerish(ID, unique = TRUE)
  }

  if (!placebo && length(cohort) == 0 && length(x) > 0) {
    message("Used best guess cohort indices!")
    # This is just assuming that consecutive patients
    # in the data set are in the same cohort if they
    # have the same dose. Note that this could be wrong,
    # if two subsequent cohorts are at the same dose.
    cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
  } else {
    assert_integerish(cohort)
  }

  .DataOrdinal(
    x = as.numeric(x),
    y = as.integer(y),
    ID = as.integer(ID),
    cohort = as.integer(cohort),
    doseGrid = doseGrid,
    nObs = length(x),
    nGrid = length(doseGrid),
    xLevel = match_within_tolerance(x = x, table = doseGrid),
    placebo = placebo,
    yCategories = yCategories
  )
}


## default constructor ----

#' @rdname DataOrdinal-class
#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
#' @export
.DefaultDataOrdinal <- function() {
  DataOrdinal(
    x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
    y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
    ID = 1L:10L,
    cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
    doseGrid = c(seq(from = 10, to = 100, by = 10)),
    yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
    placebo = FALSE
  )
}

# DataGrouped ----

## class ----

#' `DataGrouped`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DataGrouped`] is a class for a two groups dose escalation data set,
#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
#' arm. It inherits from [`Data`] and it contains the additional group information.
#'
#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
#'
#' @aliases DataGrouped
#' @export
.DataGrouped <- setClass(
  Class = "DataGrouped",
  slots = c(
    group = "factor"
  ),
  prototype = prototype(
    group = factor(levels = c("mono", "combo"))
  ),
  contains = "Data",
  validity = v_data_grouped
)

#' @rdname DataGrouped-class
#'
#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
#'   If `character` then will be coerced to `factor` with the correct levels
#'   internally.
#' @param ... parameters passed to [Data()].
#'
#' @export
#' @example examples/Data-class-DataGrouped.R
#'
DataGrouped <- function(group = character(),
                        ...) {
  d <- Data(...)
  if (!is.factor(group)) {
    assert_character(group)
    assert_subset(group, choices = c("mono", "combo"))
    group <- factor(group, levels = c("mono", "combo"))
  }
  .DataGrouped(
    d,
    group = group
  )
}

## default constructor ----

#' @rdname DataGrouped-class
#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
#' @export
.DefaultDataGrouped <- function() {
  DataGrouped(
    group = c("mono", "mono", "combo"),
    x = c(1, 3, 5),
    y = c(0, 0, 0),
    ID = 1L:3L,
    cohort = 1L:3L,
    doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
    placebo = FALSE
  )
}

#' @include Design-validity.R
#' @include Model-class.R
#' @include Rules-class.R
#' @include Data-class.R
#' @include helpers.R
#' @include CrmPackClass-class.R
NULL

# RuleDesign ----

## class ----

#' `RuleDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`RuleDesign`] is the class for rule-based designs. The difference between
#' this class and the [`Design`] class is that [`RuleDesign`] does not contain
#' `model`, `stopping` and `increments` slots.
#'
#' @slot nextBest (`NextBest`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSize`)\cr rules for the cohort sizes.
#' @slot data (`Data`)\cr specifies dose grid, any previous data, etc.
#' @slot startingDose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesign
#' @export
#'
.RuleDesign <- setClass(
  Class = "RuleDesign",
  slots = c(
    nextBest = "NextBest",
    cohort_size = "CohortSize",
    data = "Data",
    startingDose = "numeric"
  ),
  prototype = prototype(
    nextBest = .NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(3),
    data = Data(doseGrid = 1:3),
    startingDose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design
)

## constructor ----

#' @rdname RuleDesign-class
#'
#' @param nextBest (`NextBest`)\cr see slot definition.
#' @param cohort_size (`CohortSize`)\cr see slot definition.
#' @param data (`Data`)\cr see slot definition.
#' @param startingDose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesign.R
#'
RuleDesign <- function(nextBest,
                       cohort_size,
                       data,
                       startingDose) {
  new(
    "RuleDesign",
    nextBest = nextBest,
    cohort_size = cohort_size,
    data = data,
    startingDose = as.numeric(startingDose)
  )
}

#' @rdname RuleDesign-class
#' @note Typically, end users will not use the `.DefaultRuleDesign()` function.
#' @export

.DefaultRuleDesign <- function() {
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    cohort_size = CohortSizeConst(size = 3L),
    data = Data(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    startingDose = 5
  )
}

## ThreePlusThreeDesign ----

#' @describeIn RuleDesign-class creates a new 3+3 design object from a dose grid.
#'
#' @param doseGrid (`numeric`)\cr the dose grid to be used (sorted).
#'
#' @export
#' @example examples/Design-class-ThreePlusThreeDesign.R
#'
ThreePlusThreeDesign <- function(doseGrid) {
  empty_data <- Data(doseGrid = doseGrid)

  # Using a constant cohort size of 3 we obtain exactly the 3+3 design.
  RuleDesign(
    nextBest = NextBestThreePlusThree(),
    data = empty_data,
    cohort_size = CohortSizeConst(size = 3L),
    startingDose = doseGrid[1]
  )
}

# Design ----

## class ----

#' `Design`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Design`] is the class for rule-based designs. The difference between
#' this class and its parent [`RuleDesign`] class is that [`Design`] class
#' contains additional `model`, `stopping` and `increments` slots.
#'
#' @slot model (`GeneralModel`)\cr the model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases Design
#' @export
#'
.Design <- setClass(
  Class = "Design",
  slots = c(
    model = "GeneralModel",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticNormal(),
    nextBest = .NextBestNCRM(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname Design-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-Design.R
#'
#'
Design <- function(model,
                   stopping,
                   increments,
                   pl_cohort_size = CohortSizeConst(0L),
                   ...) {
  start <- RuleDesign(...)
  new(
    "Design",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname Design-class
#' @note Typically, end users will not use the `.DefaultDesign()` function.
#' @export
.DefaultDesign <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- (my_stopping1 & my_stopping2) | my_stopping3

  # Initialize the design.
  design <- Design(
    model = LogisticLogNormal(
      mean = c(-0.85, 1),
      cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
      ref_dose = 56
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = my_stopping,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    cohort_size = my_size,
    data = Data(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    startingDose = 3
  )
}

# DualDesign ----

## class ----

#' `DualDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`DualDesign`] is the class for the dual-endpoint CRM design. This class has
#' special requirements for the `model` and `data` slots in comparison to the
#' parent class [`Design`].
#'
#' @note the `nextBest` slot can be of any class, this allows for easy comparison
#'   with recommendation methods that don't use the biomarker information.
#'
#' @slot model (`DualEndpoint`)\cr the model to be used.
#' @slot data (`DataDual`)\cr specifies dose grid, any previous data, etc.
#'
#' @aliases DualDesign
#' @export
#'
.DualDesign <- setClass(
  Class = "DualDesign",
  slots = c(
    model = "DualEndpoint",
    data = "DataDual"
  ),
  prototype = prototype(
    model = .DualEndpoint(),
    nextBest = .NextBestDualEndpoint(),
    data = DataDual(doseGrid = 1:2),
    startingDose = 1
  ),
  contains = "Design"
)

## constructor ----

#' @rdname DualDesign-class
#'
#' @param model (`DualEndpoint`)\cr see slot definition.
#' @param data (`DataDual`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @export
#' @example examples/Design-class-DualDesign.R
#'
DualDesign <- function(model,
                       data,
                       ...) {
  start <- Design(model = model, data = data, ...)
  new(
    "DualDesign",
    start,
    model = model,
    data = data
  )
}

## default constructor ----

#' @rdname DualDesign-class
#' @note Typically, end users will not use the `.DefaultDualDesign()` function.
#' @export
.DefaultDualDesign <- function() {
  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  # Choose the rule for selecting the next dose.
  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  # Choose the rule for the cohort-size.
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  # Choose the rule for stopping.
  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )
  my_stopping <- my_stopping1 | StoppingMinPatients(40)

  # Choose the rule for dose increments.
  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  # Initialize the design.
  DualDesign(
    model = my_model,
    data = DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100)),
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = my_size,
    startingDose = 3
  )
}

# TDsamplesDesign ----

## class ----

#' `TDsamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDsamplesDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) as well as MCMC samples
#' obtained for this model.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDsamplesDesign
#' @export
#'
.TDsamplesDesign <- setClass(
  Class = "TDsamplesDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTDsamples(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDsamplesDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDsamplesDesign.R
#'
TDsamplesDesign <- function(model,
                            stopping,
                            increments,
                            pl_cohort_size = CohortSizeConst(0L),
                            ...) {
  start <- RuleDesign(...)
  new(
    "TDsamplesDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDsamplesDesign-class
#' @note Typically, end users will not use the `.DefaultTDsamplesDesign()` function.
#' @export
.DefaultTDsamplesDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDsamplesDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTDsamples(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3,
      derive = function(samples) {
        as.numeric(quantile(samples, probs = 0.3))
      }
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# TDDesign ----

## class ----

#' `TDDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`TDDesign`] is the class of design based only on DLT responses using
#' [`ModelTox`] class model (i.e. [`LogisticIndepBeta`]) without MCMC samples.
#'
#' @slot model (`ModelTox`)\cr the pseudo DLT model to be used.
#' @slot stopping (`Stopping`)\cr stopping rule(s) for the trial.
#' @slot increments (`Increments`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSize`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases TDDesign
#' @export
#'
.TDDesign <- setClass(
  Class = "TDDesign",
  slots = c(
    model = "ModelTox",
    stopping = "Stopping",
    increments = "Increments",
    pl_cohort_size = "CohortSize"
  ),
  prototype = prototype(
    model = .LogisticIndepBeta(),
    nextBest = .NextBestTD(),
    stopping = .StoppingMinPatients(),
    increments = .IncrementsRelative(),
    pl_cohort_size = CohortSizeConst(0L)
  ),
  contains = "RuleDesign"
)

## constructor ----

#' @rdname TDDesign-class
#'
#' @param model (`ModelTox`)\cr see slot definition.
#' @param stopping (`Stopping`)\cr see slot definition.
#' @param increments (`Increments`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSize`)\cr see slot definition.
#' @inheritDotParams RuleDesign
#'
#' @export
#' @example examples/Design-class-TDDesign.R
#'
TDDesign <- function(model,
                     stopping,
                     increments,
                     pl_cohort_size = CohortSizeConst(0L),
                     ...) {
  start <- RuleDesign(...)
  new(
    "TDDesign",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname TDDesign-class
#' @note Typically, end users will not use the `.DefaultTDDesign()` function.
#' @export
.DefaultTDDesign <- function() {
  empty_data <- Data(doseGrid = seq(25, 300, 25))

  my_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )

  TDDesign(
    model = my_model,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = range(empty_data@doseGrid),
      increments = c(2, 2)
    ),
    nextBest = NextBestTD(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    data = empty_data,
    startingDose = 25
  )
}

# DualResponsesSamplesDesign ----

## class ----

#' `DualResponsesSamplesDesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using [`ModelEff`]  model class
#' with DLE and efficacy samples. It contain all slots in
#' [`RuleDesign`] and [`TDsamplesDesign`] class objects.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesSamplesDesign
#' @export
#'
.DualResponsesSamplesDesign <-
  setClass(
    Class = "DualResponsesSamplesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGainSamples(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDsamplesDesign"
  )

## constructor ----

#' @rdname DualResponsesSamplesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDsamplesDesign
#'
#' @example examples/Design-class-DualResponsesSamplesDesign.R
#' @export
#'
DualResponsesSamplesDesign <- function(eff_model,
                                       data,
                                       ...) {
  start <- TDsamplesDesign(data = data, ...)
  .DualResponsesSamplesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesSamplesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesSamplesDesign()` function.
#' @export
.DefaultDualResponsesSamplesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  tox_model <- LogisticIndepBeta(
    binDLE = c(1.05, 1.8),
    DLEweights = c(3, 3),
    DLEdose = c(25, 300),
    data = empty_data
  )
  options <- McmcOptions(burnin = 100, step = 2, samples = 200)
  tox_samples <- mcmc(empty_data, tox_model, options)

  eff_model <- Effloglog(
    eff = c(1.223, 2.513),
    eff_dose = c(25, 300),
    nu = c(a = 1, b = 0.025),
    data = empty_data
  )
  eff_samples <- mcmc(empty_data, eff_model, options)

  my_next_best <- NextBestMaxGainSamples(
    prob_target_drt = 0.35,
    prob_target_eot = 0.3,
    derive = function(samples) {
      as.numeric(quantile(samples, prob = 0.3))
    },
    mg_derive = function(mg_samples) {
      as.numeric(quantile(mg_samples, prob = 0.5))
    }
  )

  DualResponsesSamplesDesign(
    nextBest = my_next_best,
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = tox_model,
    eff_model = eff_model,
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}

# DualResponsesDesign.R ----

## class ----

#' `DualResponsesDesign.R`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a class of design based on DLE responses using the [`LogisticIndepBeta`] model
#  and efficacy responses using the [`ModelEff`]  model class
#' without DLE and efficacy samples. It contains all slots from the
#' [`RuleDesign`] and [`TDsamplesDesign`] classes.
#
#' @slot data (`DataDual`)\cr the data set.
#' @slot eff_model (`ModelEff`)\cr the pseudo efficacy model to be used.
#'
#' @aliases DualResponsesDesign
#' @export
#'
.DualResponsesDesign <-
  setClass(
    Class = "DualResponsesDesign",
    slots = c(
      eff_model = "ModelEff",
      data = "DataDual"
    ),
    prototype = prototype(
      nextBest = .NextBestMaxGain(),
      data = DataDual(doseGrid = 1:2),
      startingDose = 1,
      model = .LogisticIndepBeta()
    ),
    contains = "TDDesign"
  )

## constructor ----

#' @rdname DualResponsesDesign-class
#'
#' @param data (`DataDual`)\cr see slot definition.
#' @param eff_model (`ModelEff`)\cr see slot definition.
#' @inheritDotParams TDDesign
#'
#' @example examples/Design-class-DualResponsesDesign.R
#' @export
#'
DualResponsesDesign <- function(eff_model,
                                data,
                                ...) {
  start <- TDDesign(data = data, ...)
  .DualResponsesDesign(
    start,
    eff_model = eff_model,
    data = data
  )
}

## default constructor ----

#' @rdname DualResponsesDesign-class
#' @note Typically, end users will not use the `.DefaultDualResponsesDesign()` function.
#' @export
.DefaultDualResponsesDesign <- function() {
  empty_data <- DataDual(doseGrid = seq(25, 300, 25))

  DualResponsesDesign(
    nextBest = NextBestMaxGain(
      prob_target_drt = 0.35,
      prob_target_eot = 0.3
    ),
    cohort_size = CohortSizeConst(size = 3),
    startingDose = 25,
    model = LogisticIndepBeta(
      binDLE = c(1.05, 1.8),
      DLEweights = c(3, 3),
      DLEdose = c(25, 300),
      data = empty_data
    ),
    eff_model = Effloglog(
      eff = c(1.223, 2.513),
      eff_dose = c(25, 300),
      nu = c(a = 1, b = 0.025),
      data = empty_data
    ),
    data = empty_data,
    stopping = StoppingMinPatients(nPatients = 36),
    increments = IncrementsRelative(
      intervals = c(25, 300),
      increments = c(2, 2)
    )
  )
}


# DADesign ----

## class ----

#' `DADesign`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class has special requirements for the `model` and `data`
#' slots in comparison to the parent class [`Design`]:
#'
#' @slot model (`GeneralModel`)\cr the model to use, see in particular [`DALogisticLogNormal`] and
#' [`TITELogisticLogNormal`] which make use of the time-to-DLT data.
#' @slot data (`DataDA`)\cr what is the dose grid, any previous data, etc.
#' @slot safetyWindow (`SafetyWindow`)\cr the safety window to apply between cohorts.
#'
#' @details
#' The `safetyWindow` slot should be an instance of the `SafetyWindow` class.
#' It can be customized to specify the duration of the safety window for your trial.
#' The safety window represents the time period required to observe toxicity data
#' from the ongoing cohort before opening the next cohort.
#' Note that even after opening the next cohort,
#' further toxicity data will be collected and analyzed to make dose escalation decisions.
#'
#'
#' To specify a constant safety window, use the `SafetyWindowConst` constructor. For example:
#'
#' \code{mysafetywindow <- SafetyWindowConst(c(6, 2), 10, 20)}
#'
#' @seealso [`SafetyWindowConst`] for creating a constant safety window.
#'
#' @aliases DADesign
#' @export
#'
.DADesign <-
  setClass(
    Class = "DADesign",
    slots = c(
      model = "GeneralModel",
      data = "DataDA",
      safetyWindow = "SafetyWindow"
    ),
    prototype = prototype(
      model = .DALogisticLogNormal(),
      nextBest = .NextBestNCRM(),
      data = DataDA(doseGrid = 1:2),
      safetyWindow = .SafetyWindowConst()
    ),
    contains = "Design"
  )


## constructor ----

#' @rdname DADesign-class
#'
#' @param model (`GeneralModel`)\cr see slot definition.
#' @param data (`DataDA`)\cr see slot definition.
#' @param safetyWindow (`SafetyWindow`)\cr see slot definition.
#' @inheritDotParams Design
#'
#' @example examples/Design-class-DADesign.R
#' @export
#'
DADesign <- function(model, data,
                     safetyWindow,
                     ...) {
  start <- Design(
    data = data,
    model = model,
    ...
  )
  .DADesign(start,
    safetyWindow = safetyWindow
  )
}

## default constructor ----

#' @rdname DADesign-class
#' @note Typically, end users will not use the `.DefaultDADesign()` function.
#' @export
.DefaultDADesign <- function() {
  emptydata <- DataDA(
    doseGrid = c(0.1, 0.5, 1, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
    Tmax = 60
  )

  npiece_ <- 10
  t_max_ <- 60

  lambda_prior <- function(k) {
    npiece_ / (t_max_ * (npiece_ - k + 0.5))
  }

  model <- DALogisticLogNormal(
    mean = c(-0.85, 1),
    cov = matrix(c(1, -0.5, -0.5, 1), nrow = 2),
    ref_dose = 56,
    npiece = npiece_,
    l = as.numeric(t(apply(as.matrix(c(1:npiece_), 1, npiece_), 2, lambda_prior))),
    c_par = 2
  )

  mySize1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  mySize2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  mySize <- maxSize(mySize1, mySize2)

  myStopping1 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  myStopping2 <- StoppingMinPatients(nPatients = 50)
  myStopping <- (myStopping1 | myStopping2)

  DADesign(
    model = model,
    increments = IncrementsRelative(
      intervals = c(0, 20),
      increments = c(1, 0.33)
    ),
    nextBest = NextBestNCRM(
      target = c(0.2, 0.35),
      overdose = c(0.35, 1),
      max_overdose_prob = 0.25
    ),
    stopping = myStopping,
    cohort_size = mySize,
    data = emptydata,
    safetyWindow = SafetyWindowConst(c(6, 2), 7, 7),
    startingDose = 3
  )
}
# DesignGrouped ----

## class ----

#' `DesignGrouped`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignGrouped`] combines two [`Design`] objects: one for the mono and one
#' for the combo arm of a joint dose escalation design.
#'
#' @slot model (`LogisticLogNormalGrouped`)\cr the model to be used, currently only one
#'   class is allowed.
#' @slot mono (`Design`)\cr defines the dose escalation rules for the mono arm, see
#'   details.
#' @slot combo (`Design`)\cr defines the dose escalation rules for the combo arm, see
#'   details.
#' @slot first_cohort_mono_only (`flag`)\cr whether first test one mono agent cohort, and then
#'   once its DLT data has been collected, we proceed from the second cohort onwards with
#'   concurrent mono and combo cohorts.
#' @slot same_dose_for_all (`flag`)\cr whether the lower dose of the separately determined mono and combo
#'   doses should be used as the next dose for both mono and combo in all cohorts.
#' @slot same_dose_for_start (`flag`)\cr indicates whether, when mono and combo are
#'   used in the same cohort for the first time, the same dose should be used for both.
#'   Note that this is different from `same_dose_for_all` which will always force
#'   them to be the same. If `same_dose_for_all = TRUE`, this is therefore ignored. See Details.
#'
#' @details
#'
#'   - Note that the model slots inside the `mono` and `combo` parameters
#'     are ignored (because we don't fit separate regression models for the mono and
#'     combo arms). Instead, the `model` parameter is used to fit a joint regression
#'     model for the mono and combo arms together.
#'   - `same_dose_for_start = TRUE` is useful as an option when we want to use `same_dose_for_all = FALSE`
#'     combined with `first_cohort_mono_only = TRUE`.
#'     This will allow to randomize patients to the mono and combo arms at the same dose
#'     as long as the selected dose for the cohorts stay the same. This can therefore
#'     further mitigate bias as long as possible between the mono and combo arms.
#'
#' @aliases DesignGrouped
#' @export
#'
.DesignGrouped <- setClass(
  Class = "DesignGrouped",
  slots = c(
    model = "LogisticLogNormalGrouped",
    mono = "Design",
    combo = "Design",
    first_cohort_mono_only = "logical",
    same_dose_for_all = "logical",
    same_dose_for_start = "logical"
  ),
  prototype = prototype(
    model = .DefaultLogisticLogNormalGrouped(),
    mono = .Design(),
    combo = .Design(),
    first_cohort_mono_only = TRUE,
    same_dose_for_all = TRUE,
    same_dose_for_start = FALSE
  ),
  validity = v_design_grouped,
  contains = "CrmPackClass"
)

## constructor ----

#' @rdname DesignGrouped-class
#'
#' @param model (`LogisticLogNormalGrouped`)\cr see slot definition.
#' @param mono (`Design`)\cr see slot definition.
#' @param combo (`Design`)\cr see slot definition.
#' @param first_cohort_mono_only (`flag`)\cr see slot definition.
#' @param same_dose_for_all (`flag`)\cr see slot definition.
#' @param same_dose_for_start (`flag`)\cr see slot definition.
#' @param stop_mono_with_combo (`flag`)\cr whether the mono arm should be stopped when the combo
#'   arm is stopped (this makes sense when the only real trial objective is the recommended combo dose).
#' @param ... not used.
#'
#' @export
#' @example examples/Design-class-DesignGrouped.R
#'
DesignGrouped <- function(model,
                          mono,
                          combo = mono,
                          first_cohort_mono_only = TRUE,
                          same_dose_for_all = !same_dose_for_start,
                          same_dose_for_start = FALSE,
                          stop_mono_with_combo = FALSE,
                          ...) {
  assert_flag(stop_mono_with_combo)
  assert_class(mono, "Design")
  force(combo)
  if (stop_mono_with_combo) {
    mono@stopping <- mono@stopping |
      StoppingExternal(report_label = "Stop Mono with Combo")
  }

  .DesignGrouped(
    model = model,
    mono = mono,
    combo = combo,
    first_cohort_mono_only = first_cohort_mono_only,
    same_dose_for_all = same_dose_for_all,
    same_dose_for_start = same_dose_for_start
  )
}

## default constructor ----

#' @rdname DesignGrouped-class
#' @note Typically, end-users will not use the `.DefaultDesignGrouped()` function.
#' @export
.DefaultDesignGrouped <- .DesignGrouped

# RuleDesignOrdinal ----

## class ----

#' `RuleDesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`RuleDesignOrdinal`] is the class for rule-based designs. The difference between
#' this class and the [`DesignOrdinal`] class is that [`RuleDesignOrdinal`]
#' does not contain `model`, `stopping` and `increments` slots.
#'
#' @slot next_best (`NextBestOrdinal`)\cr how to find the next best dose.
#' @slot cohort_size (`CohortSizeOrdinal`)\cr rules for the cohort sizes.
#' @slot data (`DataOrdinal`)\cr specifies dose grid, any previous data, etc.
#' @slot starting_dose (`number`)\cr the starting dose, it must lie on the dose
#'   grid in `data`.
#'
#' @aliases RuleDesignOrdinal
#' @export
#'
.RuleDesignOrdinal <- setClass(
  Class = "RuleDesignOrdinal",
  slots = c(
    next_best = "NextBestOrdinal",
    cohort_size = "CohortSizeOrdinal",
    data = "DataOrdinal",
    starting_dose = "numeric"
  ),
  prototype = prototype(
    next_best = .NextBestOrdinal(),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L)),
    data = DataOrdinal(doseGrid = 1:3),
    starting_dose = 1
  ),
  contains = "CrmPackClass",
  validity = v_rule_design_ordinal
)

## constructor ----

#' @rdname RuleDesignOrdinal-class
#'
#' @param next_best (`NextBestOrdinal`)\cr see slot definition.
#' @param cohort_size (`CohortSizeOrdinal`)\cr see slot definition.
#' @param data (`DataOrdinal`)\cr see slot definition.
#' @param starting_dose (`number`)\cr see slot definition.
#'
#' @export
#' @example examples/Design-class-RuleDesignOrdinal.R
#'
RuleDesignOrdinal <- function(
    next_best,
    cohort_size,
    data,
    starting_dose) {
  new(
    "RuleDesignOrdinal",
    next_best = next_best,
    cohort_size = cohort_size,
    data = data,
    starting_dose = as.numeric(starting_dose)
  )
}

#' @rdname RuleDesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultRuleDesignOrdinal()` function.
#' @export

.DefaultRuleDesignOrdinal <- function() {
  RuleDesignOrdinal(
    next_best = NextBestOrdinal(
      1L,
      NextBestMTD(target = 0.25, derive = function(x) mean(x, na.rm = TRUE))
    ),
    cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(size = 3L)),
    data = DataOrdinal(doseGrid = c(5, 10, 15, 25, 35, 50, 80)),
    starting_dose = 5
  )
}

# DesignOrdinal ----

## class ----

#' `DesignOrdinal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`DesignOrdinal`] is the class for rule-based ordinal designs. The difference
#' between this class and its parent [`RuleDesignOrdinal`] class is that the
#'  [`DesignOrdinal`] class contains additional `model`, `stopping`,
#'  `increments` and `pl_cohort_size` slots.
#'
#' @slot model (`LogisticLogNormalOrdinal`)\cr the model to be used.
#' @slot stopping (`StoppingOrdinal`)\cr stopping rule(s) for the trial.
#' @slot increments (`IncrementsOrdinal`)\cr how to control increments between dose levels.
#' @slot pl_cohort_size (`CohortSizeOrdinal`)\cr rules for the cohort sizes for placebo,
#'   if any planned (defaults to constant 0 placebo patients).
#'
#' @aliases DesignOrdinal
#' @export
#'
.DesignOrdinal <- setClass(
  Class = "DesignOrdinal",
  slots = c(
    model = "LogisticLogNormalOrdinal",
    stopping = "StoppingOrdinal",
    increments = "IncrementsOrdinal",
    pl_cohort_size = "CohortSizeOrdinal"
  ),
  prototype = prototype(
    model = .LogisticLogNormalOrdinal(),
    next_best = .NextBestOrdinal(),
    stopping = .StoppingOrdinal(),
    increments = .IncrementsOrdinal(),
    pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(3L))
  ),
  contains = "RuleDesignOrdinal"
)

## constructor ----

#' @rdname DesignOrdinal-class
#'
#' @param model (`LogisticLogNormalOrdinal`)\cr see slot definition.
#' @param stopping (`StoppingOrdinal`)\cr see slot definition.
#' @param increments (`IncrementsOrdinal`)\cr see slot definition.
#' @param pl_cohort_size (`CohortSizeOrdinal`)\cr see slot definition.
#' @inheritDotParams RuleDesignOrdinal
#'
#' @export
#' @example examples/Design-class-DesignOrdinal.R
#'
#'
DesignOrdinal <- function(
    model,
    stopping,
    increments,
    pl_cohort_size = CohortSizeOrdinal(1L, CohortSizeConst(0L)),
    ...) {
  start <- RuleDesignOrdinal(...)
  new(
    "DesignOrdinal",
    start,
    model = model,
    stopping = stopping,
    increments = increments,
    pl_cohort_size = pl_cohort_size
  )
}

## default constructor ----

#' @rdname DesignOrdinal-class
#' @note Typically, end users will not use the `.DefaultDesignOrdinal()` function.
#' @export
.DefaultDesignOrdinal <- function() {
  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- CohortSizeOrdinal(1L, maxSize(my_size1, my_size2))

  my_stopping1 <- StoppingMinCohorts(nCohorts = 3)
  my_stopping2 <- StoppingTargetProb(
    target = c(0.2, 0.35),
    prob = 0.5
  )
  my_stopping3 <- StoppingMinPatients(nPatients = 20)
  my_stopping <- StoppingOrdinal(1L, (my_stopping1 & my_stopping2) | my_stopping3)

  # Initialize the design.
  design <- DesignOrdinal(
    model = LogisticLogNormalOrdinal(
      mean = c(-3, -4, 1),
      cov = diag(c(3, 4, 1)),
      ref_dose = 50
    ),
    next_best = NextBestOrdinal(
      1L,
      NextBestNCRM(
        target = c(0.2, 0.35),
        overdose = c(0.35, 1),
        max_overdose_prob = 0.25
      )
    ),
    stopping = my_stopping,
    increments = IncrementsOrdinal(
      1L,
      IncrementsRelative(
        intervals = c(0, 20),
        increments = c(1, 0.33)
      )
    ),
    cohort_size = my_size,
    data = DataOrdinal(
      doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
      yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L)
    ),
    starting_dose = 3
  )
}

#' Internal Helper Functions for Validation of [`GeneralModel`] and [`ModelPseudo`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralModel`] and [`ModelPseudo`] or inherited classes and therefore are
#' not exported.
#'
#' @name v_model_objects
#' @param object (`GeneralModel`) or (`ModelPseudo`) \cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_objects validates that the names of the
#'   arguments in `init` function are included in `datanames` or `datanames_prior`
#'   slots.
v_general_model <- function(object) {
  v <- Validate()
  v$check(
    h_check_fun_formals(object@init, allowed = union(object@datanames, object@datanames_prior)),
    "Arguments of the init function must be data names"
  )
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters are valid.
v_model_logistic_kadane <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@theta, bounds_closed = FALSE),
    "theta must be a probability scalar > 0 and < 1"
  )
  is_xmin_number <- test_number(object@xmin)
  v$check(is_xmin_number, "xmin must be scalar")

  is_xmax_number <- test_number(object@xmax)
  v$check(is_xmax_number, "xmax must be scalar")

  if (is_xmin_number && is_xmax_number) {
    v$check(object@xmin < object@xmax, "xmin must be strictly smaller than xmax")
  }
  v$result()
}

#' @describeIn v_model_objects validates that the logistic Kadane model
#'   parameters with a beta and gamma prior are valid.
v_model_logistic_kadane_beta_gamma <- function(object) { # nolintr
  v <- Validate()
  v$check(
    test_number(object@alpha, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter alpha must be a positive scalar"
  )
  v$check(
    test_number(object@beta, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter beta must be a positive scalar"
  )
  v$check(
    test_number(object@shape, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution shape parameter must be a positive scalar"
  )
  v$check(
    test_number(object@rate, lower = .Machine$double.xmin, finite = TRUE),
    "Gamma distribution rate parameter must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `weightpar` is valid.
v_model_logistic_normal_mix <- function(object) {
  v <- Validate()
  v$check(
    h_test_named_numeric(object@weightpar, permutation.of = c("a", "b")),
    "weightpar must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `component` is a list with
#'   valid `ModelParamsNormal` objects as well as `weights` are correct.
v_model_logistic_normal_fixed_mix <- function(object) { # nolintr
  v <- Validate()
  v$check(
    all(sapply(object@components, test_class, "ModelParamsNormal")),
    "components must be a list with ModelParamsNormal S4 class objects"
  )
  comp_valid_result <- sapply(object@components, validObject, test = TRUE)
  comp_valid <- sapply(comp_valid_result, isTRUE)
  v$check(
    all(comp_valid),
    paste(
      "components must be a list with valid ModelParamsNormal S4 class objects",
      paste(unlist(comp_valid_result[!comp_valid]), collapse = ", "),
      collapse = ", ",
      sep = ", "
    )
  )
  v$check(
    length(object@components) == length(object@weights),
    "components must have same length as weights"
  )
  v$check(
    test_numeric(object@weights, lower = .Machine$double.xmin, finite = TRUE, any.missing = FALSE),
    "weights must be positive"
  )
  v$check(
    sum(object@weights) == 1,
    "weights must sum to 1"
  )
  v$check(
    test_flag(object@log_normal),
    "log_normal must be TRUE or FALSE"
  )
  v$result()
}

#' @describeIn v_model_objects validates that `share_weight` represents probability.
v_model_logistic_log_normal_mix <- function(object) { # nolintr
  v <- Validate()
  v$check(
    test_probability(object@share_weight),
    "share_weight does not specify a probability"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpoint`] class slots are valid.
v_model_dual_endpoint <- function(object) {
  rmin <- .Machine$double.xmin
  v <- Validate()

  v$check(
    test_flag(object@use_log_dose),
    "use_log_dose must be TRUE or FALSE"
  )
  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_rho <- object@use_fixed["rho"]
  v$check(
    test_flag(uf_rho),
    "use_fixed must be a named logical vector that contains name 'rho'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  if (isTRUE(uf_rho)) {
    v$check(
      test_number(object@rho, lower = -1 + rmin, upper = 1 - rmin), # rmin is ignored here!
      "rho must be a number in (-1, 1)"
    )
  } else {
    # object@rho is a vector with parameters for Beta(a, b).
    v$check(
      h_test_named_numeric(object@rho, permutation.of = c("a", "b")),
      "rho must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointRW`] class slots are valid.
v_model_dual_endpoint_rw <- function(object) {
  v <- Validate()
  uf_sigma2W <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )
  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2betaW, lower = .Machine$double.xmin, finite = TRUE),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointBeta`] class slots are valid.
v_model_dual_endpoint_beta <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "delta1", "mode")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0("use_fixed must be a named logical vector that contains name '", s, "'")
    )
    if (isTRUE(uf)) {
      if (s %in% c("delta1", "mode")) {
        v$check(
          test_number(slot(object, s), lower = rmin, finite = TRUE),
          paste(s, "must be a positive and finite numerical scalar")
        )
      }
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(s, "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values")
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`DualEndpointEmax`] class slots are valid.
v_model_dual_endpoint_emax <- function(object) {
  v <- Validate()

  for (s in c("E0", "Emax", "ED50")) {
    rmin <- .Machine$double.xmin
    uf <- object@use_fixed[s]

    v$check(
      test_flag(uf),
      paste0("use_fixed must be a named logical vector that contains name '", s, "'")
    )
    if (isTRUE(uf)) {
      v$check(
        test_number(slot(object, s), lower = rmin, finite = TRUE),
        paste(s, "must be a positive and finite numerical scalar")
      )
    } else {
      # s is a vector with parameters for Uniform(s[1], s[2]) prior.
      v$check(
        test_numeric(
          slot(object, s),
          lower = 0,
          finite = TRUE,
          any.missing = FALSE,
          len = 2,
          unique = TRUE,
          sorted = TRUE
        ),
        paste(s, "must be a numerical vector of length two with non-negative, finite, unique and sorted (asc.) values")
      )
    }
  }

  v$result()
}

#' @describeIn v_model_objects validates that [`LogisticIndepBeta`] class slots are valid.
v_model_logistic_indep_beta <- function(object) {
  v <- Validate()

  dle_len <- length(object@binDLE)
  v$check(
    test_numeric(object@binDLE, finite = TRUE, any.missing = FALSE, min.len = 2),
    "binDLE must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(object@DLEdose, finite = TRUE, any.missing = FALSE, len = dle_len),
    "DLEdose must be a finite numerical vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_integer(object@DLEweights, any.missing = FALSE, len = dle_len),
    "DLEweights must be an integer vector of the same length as 'binDLE', without missing values"
  )
  v$check(
    test_number(object@phi1),
    "phi1 must be a numerical scalar"
  )
  v$check(
    test_number(object@phi2),
    "phi2 must be a numerical scalar"
  )
  v$check(
    h_is_positive_definite(object@Pcov),
    "Pcov must be 2x2 positive-definite matrix without any missing values"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`Effloglog`] class slots are valid.
v_model_eff_log_log <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  eff_dose_ok <- test_numeric(
    object@eff_dose,
    lower = rmin, finite = TRUE, any.missing = FALSE, len = length(object@eff)
  )
  v$check(
    eff_dose_ok,
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )
  v$check(
    test_flag(object@use_fixed),
    "use_fixed must be a flag"
  )
  if (isTRUE(object@use_fixed)) {
    v$check(
      test_number(object@nu, lower = rmin, finite = TRUE),
      "nu must be a positive and finite numerical scalar"
    )
  } else {
    # object@nu is a vector with parameters for Gamma(a, b).
    v$check(
      h_test_named_numeric(object@nu, permutation.of = c("a", "b")),
      "nu must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  const_ok <- test_number(object@const, lower = 0)
  v$check(const_ok, "const must be a non-negative number")
  if (eff_dose_ok && const_ok) {
    v$check(
      min(object@data@doseGrid, object@eff_dose) > 1 - object@const,
      "For log-log model, doses and const must be such that dose + const > 1"
    )
  }
  v$check(
    test_number(object@theta1),
    "theta1 must be a numerical scalar"
  )
  v$check(
    test_number(object@theta2),
    "theta2 must be a numerical scalar"
  )
  nobs_no_dlt <- sum(!object@data@y)
  if (nobs_no_dlt + length(object@eff) > 2) {
    v$check(
      h_is_positive_definite(object@Pcov),
      "Pcov must be 2x2 positive-definite matrix without any missing values"
    )
  } else {
    v$check(
      test_matrix(object@Pcov, mode = "numeric", nrows = 2, ncols = 2) && all(is.na(object@Pcov)),
      "Pcov must be 2x2 numeric matrix with all values missing if the length of combined data is 2"
    )
  }
  v$check(
    test_numeric(object@mu, finite = TRUE, len = 2),
    "mu must be a finite numerical vector of length 2"
  )
  Xnrow <- ifelse(nobs_no_dlt > 0, nobs_no_dlt, length(object@eff_dose))
  v$check(
    test_matrix(object@X, mode = "numeric", nrows = Xnrow, ncols = 2, any.missing = FALSE),
    paste(
      "X must be a finite numerical matrix of size",
      Xnrow,
      "x 2, without any missing values"
    )
  )
  v$check(
    all(object@X[, 1] == 1),
    "X must be a design matrix, i.e. first column must be of 1s"
  )
  v$check(
    h_is_positive_definite(object@Q),
    "Q must be 2x2 positive-definite matrix without any missing values"
  )
  v$check(
    test_numeric(object@Y, finite = TRUE, any.missing = FALSE, len = Xnrow),
    paste(
      "Y must be a finite numerical vector of length",
      Xnrow,
      "and without any missing values"
    )
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`EffFlexi`] class slots are valid.
v_model_eff_flexi <- function(object) {
  rmin <- .Machine$double.xmin

  v <- Validate()
  v$check(
    test_numeric(object@eff, finite = TRUE, any.missing = FALSE, min.len = 2),
    "eff must be a finite numerical vector of minimum length 2, without missing values"
  )
  v$check(
    test_numeric(
      object@eff_dose,
      lower = rmin, finite = TRUE, any.missing = FALSE, len = length(object@eff)
    ),
    "eff_dose must be a finite numerical vector of the same length as 'eff', without missing values"
  )

  uf_sigma2W <- object@use_fixed["sigma2W"] # nolintr
  v$check(
    test_flag(uf_sigma2W),
    "use_fixed must be a named logical vector that contains name 'sigma2W'"
  )
  uf_sigma2betaW <- object@use_fixed["sigma2betaW"] # nolintr
  v$check(
    test_flag(uf_sigma2betaW),
    "use_fixed must be a named logical vector that contains name 'sigma2betaW'"
  )

  if (isTRUE(uf_sigma2W)) {
    v$check(
      test_number(object@sigma2W, lower = rmin, finite = TRUE),
      "sigma2W must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2W is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2W, permutation.of = c("a", "b")),
      "sigma2W must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }
  if (isTRUE(uf_sigma2betaW)) {
    v$check(
      test_number(object@sigma2betaW, lower = rmin, finite = TRUE),
      "sigma2betaW must be a positive and finite numerical scalar"
    )
  } else {
    # object@sigma2betaW is a vector with parameters for InverseGamma(a, b).
    v$check(
      h_test_named_numeric(object@sigma2betaW, permutation.of = c("a", "b")),
      "sigma2betaW must be a named numerical vector of length two with positive finite values and names 'a', 'b'"
    )
  }

  v$check(
    test_flag(object@rw1),
    "rw1 must be a flag"
  )
  v$check(
    test_matrix(object@X, mode = "integer", ncols = object@data@nGrid, any.missing = FALSE),
    paste("X must be an integer matrix with", object@data@nGrid, "columns and without any missing values")
  )
  v$check(
    all(object@X == 0L | object@X == 1L),
    "X must be a matrix with 0-1 values only"
  )
  v$check(
    test_matrix(object@RW, nrows = object@data@nGrid, ncols = object@data@nGrid, any.missing = FALSE),
    paste0("RW must be ", object@data@nGrid, "x", object@data@nGrid, " matrix without any missing values")
  )
  v$check(
    test_int(object@RW_rank) && (object@RW_rank == (object@data@nGrid - ifelse(isTRUE(object@rw1), 1L, 2L))),
    "RW_rank must be an integer equal to data@nGrid - 2L"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`DALogisticLogNormal`] class slots are valid.
v_model_da_logistic_log_normal <- function(object) {
  v <- Validate()

  npiece_ok <- test_int(object@npiece)
  v$check(npiece_ok, "npiece must be a is a single integerish value")
  if (npiece_ok) {
    v$check(
      test_numeric(object@l, lower = 0, finite = TRUE, any.missing = FALSE, len = object@npiece),
      "prior parameter vector l of lambda must be a non-negative vector of length equal to npiece"
    )
  }
  v$check(
    test_number(object@c_par, finite = TRUE),
    "c_par must be a finite numerical scalar"
  )
  v$check(
    test_flag(object@cond_pem),
    "cond_pem must be a flag"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`TITELogisticLogNormal`] class slots are valid.
v_model_tite_logistic_log_normal <- function(object) { # nolintr
  v <- Validate()
  v$check(
    test_string(object@weight_method, pattern = "^linear$|^adaptive$"),
    "weight_method must be a string equal either to linear or adaptive"
  )
  v$result()
}

#' @describeIn v_model_objects validates that [`OneParLogNormalPrior`] class slots are valid.
v_model_one_par_exp_normal_prior <- function(object) { # nolintr
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(object@skel_probs, unique = TRUE, sorted = TRUE)
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(from = skel_probs_range[1], to = skel_probs_range[2], by = 0.01)
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_out_range), rep(skel_probs_range, each = 3))),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@sigma2, lower = .Machine$double.xmin, finite = TRUE),
    "sigma2 must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects validates that [`OneParExpPrior`] class slots are valid.
v_model_one_par_exp_prior <- function(object) {
  v <- Validate()

  is_skel_prob_ok <- test_probabilities(object@skel_probs, unique = TRUE, sorted = TRUE)
  v$check(
    is_skel_prob_ok,
    "skel_probs must be a unique sorted probability values between 0 and 1"
  )

  if (is_skel_prob_ok) {
    # Validating skel_fun/skel_fun_inv on within the range of skeleton probs.
    skel_probs_range <- range(object@skel_probs)
    # Probabilities within the range of skel_probs.
    probs_in_range <- seq(from = skel_probs_range[1], to = skel_probs_range[2], by = 0.01)
    # Interpolated dose grid.
    doses_in_range <- object@skel_fun_inv(probs_in_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_in_range), probs_in_range)),
      "skel_fun_inv must be an inverse funtion of skel_fun function on within the range of sekeleton probs"
    )

    # Validating skel_fun/skel_fun_inv on outside the range of skeleton probs.
    probs_out_range <- c(
      seq(from = 0, to = skel_probs_range[1], length.out = 3),
      seq(from = skel_probs_range[2], to = 1, length.out = 3)
    )
    doses_out_range <- object@skel_fun_inv(probs_out_range)
    v$check(
      isTRUE(all.equal(object@skel_fun(doses_out_range), rep(skel_probs_range, each = 3))),
      "skel_fun_inv must be an inverse funtion of skel_fun function on outside the range of sekeleton probs"
    )
  }

  v$check(
    test_number(object@lambda, lower = .Machine$double.xmin, finite = TRUE),
    "lambda must be a positive finite number"
  )

  v$result()
}

#' @describeIn v_model_objects confirms that cov is diagonal
v_logisticlognormalordinal <- function(object) {
  v <- Validate()
  # diag(x) returns a vector, not a matrix, so cannot use identical(x, diag(x)
  x <- object@params@cov
  diag(x) <- rep(0, ncol(x))
  v$check(
    all(x == 0),
    "covariance matrix must be diagonal"
  )
  v$result()
}

#' @include helpers_data.R

# plot ----

## Data ----

#' Plot Method for the [`Data`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`] object.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-Data
#' @rdname plot-Data
#' @export
#' @example examples/Data-method-plot.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "Data", y = "missing"),
  definition = function(x, y, blind = FALSE, legend = TRUE, ...) {
    assert_flag(blind)
    assert_flag(legend)
    h_plot_data_dataordinal(x, blind, legend, ...)
  }
)

#' Plot Method for the [`DataOrdinal`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that creates a plot for [`DataOrdinal`] object.
#'
#' @param x (`DataOrdinal`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param legend (`flag`)\cr whether the legend should be added.
#' @param tox_labels (`named list of character`)\cr the labels of the toxicity
#' categories.
#' @param tox_shapes (`names list of integers`)\cr the symbols used to identify
#' the toxicity categories.
#' @param ... not used.
#'
#' @note With more than 9 toxicity categories, toxicity symbols must be
#' specified manually.\cr With more than 5 toxicity categories, toxicity labels
#' must be specified manually.
#'
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
#' @export
#' @example examples/DataOrdinal-method-plot.R
setMethod(
  f = "plot",
  signature = signature(x = "DataOrdinal", y = "missing"),
  definition = function(x,
                        y,
                        blind = FALSE,
                        legend = TRUE,
                        tox_labels = NULL,
                        tox_shapes = NULL,
                        ...) {
    if (is.null(tox_shapes)) {
      assert_true(length(x@yCategories) <= 9)
      tox_shapes <- c(17L, 16L, 15L, 18L, 0L:2L, 5L, 6L)[seq_along(x@yCategories)]
      names(tox_shapes) <- names(x@yCategories)
    }
    if (is.null(tox_labels)) {
      assert_true(length(x@yCategories) <= 5)
      tox_labels <- switch(length(x@yCategories),
        c("black"),
        c("black", "red"),
        c("black", "orange", "red"),
        c("black", "green", "orange", "red"),
        c("black", "green", "yellow", "orange", "red")
      )
      names(tox_labels) <- names(x@yCategories)
    }
    h_plot_data_dataordinal(
      x,
      blind,
      legend,
      tox_labels = tox_labels,
      tox_shapes = tox_shapes,
      ...
    )
  }
)

## DataDual ----

#' Plot Method for the [`DataDual`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDual`] object.
#'
#' @param x (`DataDual`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDual
#' @export
#' @example examples/Data-method-plot-DataDual.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDual", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Create the second, biomarker plot.
    df <- h_plot_data_df(x, blind, biomarker = x@w)

    plot2 <- ggplot(df, aes(x = dose, y = biomarker)) +
      geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
      scale_colour_manual(
        name = "Toxicity", values = c(Yes = "red", No = "black")
      ) +
      scale_shape_manual(name = "Toxicity", values = c(Yes = 17, No = 16)) +
      xlab("Dose Level") +
      ylab("Biomarker")

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(
            y = biomarker + 0.02 * diff(range(biomarker)),
            label = patient, size = 2
          ),
          data = df,
          hjust = 0,
          vjust = 0.5,
          angle = 90,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
  }
)

## DataDA ----

#' Plot Method for the [`DataDA`] Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`DataDA`] object.
#'
#' @param x (`DataDA`)\cr object we want to plot.
#' @param y (`missing`)\cr missing object, for compatibility with the generic
#'   function.
#' @param blind (`flag`)\cr indicates whether to blind the data.
#'   If `TRUE`, then placebo subjects are reported at the same level
#'   as the active dose level in the corresponding cohort,
#'   and DLTs are always assigned to the first subjects in a cohort.
#' @param ... passed to the first inherited method `plot` after this current
#'   method.
#'
#' @return The [`ggplot2`] object.
#'
#' @aliases plot-DataDA
#' @export
#' @example examples/Data-method-plot-DataDA.R
#'
setMethod(
  f = "plot",
  signature = signature(x = "DataDA", y = "missing"),
  definition = function(x, y, blind = FALSE, ...) {
    assert_flag(blind)

    # Call the superclass method, to get the first plot.
    plot1 <- callNextMethod(x, blind = blind, legend = FALSE, ...)

    # Prepare data set for the second, time plot.
    df <- h_plot_data_df(x, blind, u = x@u, t0 = x@t0)
    df$censored <- ifelse(df$u < x@Tmax & df$toxicity == 0, 1, 0)
    df$tend <- df$t0 + df$u # `tend` stands for `time end`
    df$t0_case <- "Start"
    df$tend_case <- ifelse(
      df$toxicity == "Yes",
      "Yes",
      ifelse(df$censored, "Censored", "No")
    )

    # Build plot object.
    plot2 <- ggplot(df, aes(x = t0, y = patient)) +
      geom_segment(aes(xend = tend, yend = patient)) +
      geom_point(aes(shape = t0_case, colour = t0_case), size = 3) +
      geom_point(
        aes(x = tend, shape = tend_case, colour = tend_case),
        size = 3
      ) +
      scale_colour_manual(
        name = "Toxicity",
        values = c(
          Yes = "red", No = "black", Start = "black", Censored = "black"
        )
      ) +
      scale_shape_manual(
        name = "Toxicity",
        values = c(Yes = 17, No = 16, Start = 1, Censored = 4)
      ) +
      scale_y_continuous(breaks = df$patient, minor_breaks = NULL) +
      xlab("Time") +
      ylab("Patient")

    plot2 <- plot2 +
      h_plot_data_cohort_lines(df$cohort, placebo = x@placebo, vertical = FALSE)

    if (!blind) {
      plot2 <- plot2 +
        geom_text(
          aes(label = ID, size = 2),
          size = 3,
          hjust = 1.5,
          vjust = 0,
          angle = 0,
          colour = "black",
          show.legend = FALSE
        )
    }

    # Arrange both plots side by side.
    gridExtra::arrangeGrob(plot1, plot2, ncol = 1)
  }
)

# update ----

## Data ----

#' Updating `Data` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`Data`] object with new data.
#'
#' @param object (`Data`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the DLT vector (0/1 vector) for all patients in this
#'   cohort. You can also supply `numeric` vectors, but these will then be
#'   converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See details below.
#' @param ... not used.
#'
#' @return The new, updated [`Data`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `Data` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-Data
#' @export
#' @example examples/Data-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "Data"),
  definition = function(object,
                        x,
                        y,
                        ID = length(object@ID) + seq_along(y),
                        new_cohort = TRUE,
                        check = TRUE,
                        ...) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
    assert_integerish(ID, len = length(y), any.missing = FALSE)
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataOrdinal ----

#' Updating `DataOrdinal` Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that updates existing [`DataOrdinal`] object with new data.
#'
#' @param object (`DataOrdinal`)\cr object you want to update.
#' @param x (`number`)\cr the dose level (one level only!).
#' @param y (`integer`)\cr the vector of toxicity grades (0, 1, 2, ...) for all
#' patients in this cohort. You can also supply `numeric` vectors, but these
#' will then be converted to `integer` internally.
#' @param ID (`integer`)\cr the patient IDs.
#'   You can also supply `numeric` vectors, but these will then be converted to
#'   `integer` internally.
#' @param new_cohort (`flag`)\cr if `TRUE` (default) the new data are assigned
#'   to a new cohort.
#' @param check (`flag`)\cr whether the validation of the updated object should
#'   be conducted. See Details below.
#' @param ... not used.
#'
#' @return The new, updated [`DataOrdinal`] object.
#'
#' @details The current implementation of this `update` method allows for
#'   updating the `DataOrdinal` class object by adding a single dose level `x` only.
#'   However, there might be some use cases where the new cohort to be added
#'   contains a placebo and active dose. Hence, such update would need to be
#'   performed iteratively by calling the `update` method twice. For example,
#'   in the first call a user can add a placebo, and then in the second call,
#'   an active dose. Since having a cohort with placebo only is not allowed,
#'   the `update` method would normally throw the error when attempting to add
#'   a placebo in the first call. To allow for such updates, the `check`
#'   parameter should be then set to `FALSE` for that first call.
#'
#' @aliases update-DataOrdinal
#' @export
#' @example examples/DataOrdinal-method-update.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataOrdinal"),
  definition = function(object,
                        x,
                        y,
                        ID = length(object@ID) + seq_along(y),
                        new_cohort = TRUE,
                        check = TRUE,
                        ...) {
    assert_numeric(x, min.len = 0, max.len = 1)
    assert_integerish(y, lower = 0, upper = length(object@yCategories) - 1, any.missing = FALSE)
    assert_integerish(ID, unique = TRUE, any.missing = FALSE, len = length(y))
    assert_disjunct(object@ID, ID)
    assert_flag(new_cohort)
    assert_flag(check)

    # How many additional patients, ie. the length of the update.
    n <- length(y)

    # Which grid level is the dose?
    gridLevel <- match_within_tolerance(x, object@doseGrid)
    object@xLevel <- c(object@xLevel, rep(gridLevel, n))

    # Add dose.
    object@x <- c(object@x, rep(as.numeric(x), n))

    # Add DLT data.
    object@y <- c(object@y, as.integer(y))

    # Add ID.
    object@ID <- c(object@ID, as.integer(ID))

    # Add cohort number.
    new_cohort_id <- if (object@nObs == 0) {
      1L
    } else {
      tail(object@cohort, 1L) + ifelse(new_cohort, 1L, 0L)
    }
    object@cohort <- c(object@cohort, rep(new_cohort_id, n))

    # Increment sample size.
    object@nObs <- object@nObs + n

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataParts ----

#' Updating `DataParts` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataParts`] object with new data.
#'
#' @param object (`DataParts`)\cr object you want to update.
#' @inheritParams update,Data-method
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataParts`] object.
#'
#' @aliases update-DataParts
#' @export
#' @example examples/Data-method-update-DataParts.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataParts"),
  definition = function(object, x, y, ..., check = TRUE) {
    assert_numeric(y)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, x = x, y = y, ..., check = FALSE)

    # Update the part information.

    object@part <- c(object@part, rep(object@nextPart, length(y)))

    # Decide which part the next cohort will belong to:
    # only if the `nextPart` was 1, it can potentially be required
    # to change it to 2 (once it is 2, it stays).
    if (object@nextPart == 1L) {
      # If there was a DLT in one of the cohorts,
      # or if the current dose was the highest from part 1.
      if (any(object@y == 1L) || x == max(object@part1Ladder)) {
        # Then this closes part 1 and the next cohort will be from part 2.
        object@nextPart <- 2L
      }
    }

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDual ----

#' Updating `DataDual` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDual`] object with new data.
#'
#' @param object (`DataDual`)\cr object you want to update.
#' @param w (`numeric`)\cr the continuous vector of biomarker values
#'   for all the patients in this update.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDual`] object.
#'
#' @aliases update-DataDual
#' @export
#' @example examples/Data-method-update-DataDual.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDual"),
  definition = function(object, w, ..., check = TRUE) {
    assert_numeric(w)
    assert_flag(check)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(object = object, ..., check = FALSE)

    # Update the biomarker information.
    object@w <- c(object@w, w)

    if (check) {
      validObject(object)
    }

    object
  }
)

## DataDA ----

#' Updating `DataDA` Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that updates existing [`DataDA`] object with new data.
#'
#' @note This function is capable of not only adding new patients but also
#'   updates existing ones with respect to `y`, `t0`, `u` slots.
#'
#' @param object (`DataDA`)\cr object you want to update.
#' @param u (`numeric`)\cr the new DLT free survival times for all patients,
#'   i.e. for existing patients in the `object` as well as for new patients.
#' @param t0 (`numeric`)\cr the time that each patient starts DLT observation
#'   window. This parameter covers all patients, i.e. existing patients in the
#'   `object` as well as for new patients.
#' @param trialtime (`number`)\cr current time in the trial, i.e. a followup
#'   time.
#' @param y (`numeric`)\cr the new DLTs for all patients, i.e. for existing
#'   patients in the `object` as well as for new patients.
#' @param ... further arguments passed to `Data` update method [`update-Data`].
#'   These are used when there are new patients to be added to the cohort.
#' @param check (`flag`)\cr whether the validation of the updated object
#'   should be conducted. See help for [`update-Data`] for more details
#'   on the use case of this parameter.
#'
#' @return The new, updated [`DataDA`] object.
#'
#' @aliases update-DataDA
#' @export
#' @example examples/Data-method-update-DataDA.R
#'
setMethod(
  f = "update",
  signature = signature(object = "DataDA"),
  definition = function(object,
                        u,
                        t0,
                        trialtime,
                        y,
                        ...,
                        check = TRUE) {
    assert_flag(check)
    assert_numeric(y, lower = 0, upper = 1)
    assert_true(length(y) == 0 || length(y) >= object@nObs)
    assert_numeric(u, lower = 0, len = length(y))
    assert_numeric(t0, lower = 0, len = length(y))
    assert_integerish(y * (trialtime >= t0 + u))
    if (length(y) > 0) {
      assert_number(trialtime, lower = max(c(object@t0, t0)))
    }

    # How many additional patients.
    n <- max(length(y) - object@nObs, 0L)

    # Update slots corresponding to `Data` class.
    object <- callNextMethod(
      object = object,
      y = y[object@nObs + seq_len(n)], # Empty vector when n = 0.
      ...,
      check = FALSE
    )

    # DLT will be observed once the followup time >= the time to DLT
    # and y = 1 at the same time.
    object@y <- as.integer(y * (trialtime >= t0 + u))

    # Update DLT free survival time.
    object@u <- apply(rbind(u, trialtime - t0), 2, min)

    # Update t0.
    object@t0 <- t0

    if (check) {
      validObject(object)
    }

    object
  }
)

# getEff ----

## generic ----

#' Extracting Efficacy Responses for Subjects Categorized by the DLT
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that extracts efficacy responses for subjects and categorizes it
#' with respect to DLT, i.e. DLT or no DLT. The efficacy responses
#' are reported together with their corresponding dose levels.
#'
#' @param object (`DataDual`)\cr object from which the responses and dose levels
#'   are extracted.
#' @param ... further arguments passed to class-specific methods.
#' @return `list` with efficacy responses categorized by the DLT value.
#' @export
#'
setGeneric(
  name = "getEff",
  def = function(object, ...) {
    standardGeneric("getEff")
  },
  valueClass = "list"
)

## DataDual ----

#' @rdname getEff
#'
#' @param no_dlt (`flag`)\cr should only no DLT responses be returned? Otherwise,
#'   all responses are returned.
#'
#' @aliases getEff-DataDual
#' @example examples/Data-method-getEff.R
#'
setMethod(
  f = "getEff",
  signature = signature(object = "DataDual"),
  definition = function(object, no_dlt = FALSE) {
    assert_flag(no_dlt)

    is_dlt <- object@y == 1L
    is_no_dlt <- !is_dlt

    eff <- if (any(is_no_dlt)) {
      list(x_no_dlt = object@x[is_no_dlt], w_no_dlt = object@w[is_no_dlt])
    } else {
      list(x_no_dlt = NULL, w_no_dlt = NULL)
    }

    if (!no_dlt) {
      eff_dlt <- if (any(is_dlt)) {
        list(x_dlt = object@x[is_dlt], w_dlt = object@w[is_dlt])
      } else {
        list(x_dlt = NULL, w_dlt = NULL)
      }
      eff <- c(eff, eff_dlt)
    }
    eff
  }
)

# ngrid ----

## generic ----

#' Number of Doses in Grid
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that gets the number of doses in grid. User can choose whether
#' the placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#' @param ... further arguments passed to class-specific methods.
#' @return `integer` the number of doses in grid.
#' @export
#'
setGeneric(
  name = "ngrid",
  def = function(object, ignore_placebo = TRUE, ...) {
    assert_flag(ignore_placebo)
    standardGeneric("ngrid")
  },
  valueClass = "integer"
)

## Data ----

#' @rdname ngrid
#'
#' @aliases ngrid-Data
#' @example examples/Data-method-ngrid.R
#'
setMethod(
  f = "ngrid",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo, ...) {
    if (ignore_placebo && object@placebo) {
      max(object@nGrid - 1L, 0L)
    } else {
      object@nGrid
    }
  }
)

# dose_grid_range ----

## generic ----

#' Getting the Dose Grid Range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A function that returns a vector of length two with the minimum and maximum
#' dose in a grid. It returns `c(-Inf, Inf)` if the range cannot be determined,
#' which happens when the dose grid is empty. User can choose whether the
#' placebo dose (if any) should be counted or not.
#'
#' @param object (`Data`)\cr object with dose grid.
#' @param ... further arguments passed to class-specific methods.
#' @return A `numeric` vector containing the minimum and maximum of all the
#'   doses in a grid or `c(-Inf, Inf)`.
#'
#' @export
#'
setGeneric(
  name = "dose_grid_range",
  def = function(object, ...) {
    standardGeneric("dose_grid_range")
  },
  valueClass = "numeric"
)

## Data ----

#' @rdname dose_grid_range
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/Data-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "Data"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)


## DataOrdinal ----

#' @include Data-methods.R
#' @rdname dose_grid_range
#' @description `r lifecycle::badge("experimental")`
#'
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
#' @aliases dose_grid_range-Data
#' @example examples/DataOrdinal-method-dose_grid_range.R
#'
setMethod(
  f = "dose_grid_range",
  signature = signature(object = "DataOrdinal"),
  definition = function(object, ignore_placebo = TRUE) {
    h_obtain_dose_grid_range(object, ignore_placebo)
  }
)

# tidy ----

## GeneralData ----

#' Tidy Method for the [`GeneralData`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`GeneralData`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-GeneralData
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "GeneralData"),
  definition = function(x, ...) {
    d <- tibble::tibble(
      ID = x@ID,
      Cohort = x@cohort,
      Dose = x@x,
      XLevel = x@xLevel,
      Tox = as.logical(x@y),
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid)
    ) %>% h_tidy_class(x)
  }
)

## DataGrouped ----

#' Tidy Method for the [`DataGrouped`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataGrouped`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataGrouped
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataGrouped"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(Group = x@group) %>%
      h_tidy_class(x)
  }
)

## DataDA ----

#' Tidy Method for the [`DataDA`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataDA`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataDA
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataDA"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(U = x@u) %>%
      tibble::add_column(T0 = x@t0) %>%
      tibble::add_column(TMax = x@Tmax) %>%
      h_tidy_class(x)
  }
)

## DataDA ----

#' Tidy Method for the [`DataDual`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataDual`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataDual
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataDual"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(W = x@w) %>%
      h_tidy_class(x)
  }
)

## DataParts ----

#' Tidy Method for the [`DataParts`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataParts`] object.
#'
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataParts
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataParts"),
  definition = function(x, ...) {
    d <- callNextMethod()
    d %>%
      tibble::add_column(Part = x@part) %>%
      tibble::add_column(NextPart = x@nextPart) %>%
      tibble::add_column(Part1Ladder = list(x@part1Ladder)) %>%
      h_tidy_class(x)
  }
)

## DataMixture ----

#' Tidy Method for the [`DataMixture`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataMixture`] object.
#' @section Usage Notes:
#' The prior observations are indicated by a `Cohort` value of `0` in the returned
#' `tibble`.
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataMixture
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataMixture"),
  definition = function(x, ...) {
    observed <- callNextMethod()
    tibble::tibble(
      Cohort = 0,
      Dose = x@xshare,
      Tox = as.logical(x@yshare),
      ID = sort(seq_along(x@xshare)),
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid),
      XLevel = which(x@doseGrid %in% x@xshare)
    ) %>%
      dplyr::bind_rows(observed) %>%
      h_tidy_class(x)
  }
)


## DataOrdinal ----

#' Tidy Method for the [`DataMixture`] Class
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that tidies a [`DataOrdinal`] object.
#' @section Usage Notes:
#' @return The [`tibble`] object.
#'
#' @aliases tidy-DataOrdinal
#' @rdname tidy
#' @export
#' @example examples/GeneralData-method-tidy.R
#'
setMethod(
  f = "tidy",
  signature = signature(x = "DataOrdinal"),
  definition = function(x, ...) {
    tibble::tibble(
      ID = x@ID,
      Cohort = x@cohort,
      Dose = x@x,
      Tox = x@y,
      Placebo = x@placebo,
      NObs = x@nObs,
      NGrid = x@nGrid,
      DoseGrid = list(x@doseGrid),
      XLevel = x@xLevel
    ) %>%
      tidyr::pivot_wider(
        names_from = "Tox",
        values_from = "Tox",
        names_prefix = "Cat",
        values_fill = 0
      ) %>%
      dplyr::mutate(dplyr::across(tidyselect::matches("Cat\\d+"), \(x) x > 0)) %>%
      h_tidy_class(x)
  }
)

#' @include McmcOptions-class.R
#' @include Model-methods.R
#' @include fromQuantiles.R
NULL

# size ----

## Samples ----

#' @describeIn size get the number of MCMC samples from `Samples` object.
#' @aliases size-Samples
#'
#' @export
#' @example examples/Samples-methods-size.R
#'
setMethod(
  f = "size",
  signature = signature(object = "Samples"),
  definition = function(object, ...) {
    size(object@options)
  }
)

# names ----

## Samples ----

#' The Names of the Sampled Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that returns names of the parameters that are sampled.
#'
#' @param x (`Samples`)\cr object with samples.
#'
#' @aliases names-Samples
#' @export
#' @example examples/Samples-methods-names.R
#'
setMethod(
  f = "names",
  signature = signature(x = "Samples"),
  definition = function(x) {
    names(x@data)
  }
)

## --------------------------------------------------
## Extract certain parameter from "Samples" object to produce
## plots with "ggmcmc" package
## --------------------------------------------------

# The next line is required to suppress the message "Creating a generic function
# for ‘get’ from package ‘base’ in package ‘crmPack’" on package load.
# See https://github.com/Roche/crmPack/issues/723
setGeneric("get")

#' Get specific parameter samples and produce a data.frame
#'
#' Here you have to specify with \code{pos} which
#' parameter you would like to extract from the \code{\linkS4class{Samples}}
#' object
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param pos the name of the parameter
#' @param envir for vectorial parameters, you can give the indices of the
#' elements you would like to extract. If \code{NULL}, the whole vector samples
#' will be returned
#' @param mode not used
#' @param inherits not used
#'
#' @return the data frame suitable for use with \code{\link[ggmcmc]{ggmcmc}}
#'
#' @example examples/Sample-methods-get.R
#' @export
#' @keywords methods
setMethod("get",
  signature =
    signature(
      x = "Samples",
      pos = "character",
      envir = "ANY",
      mode = "ANY",
      inherits = "ANY"
    ),
  def =
    function(x,
             pos,
             envir = NULL,
             mode = NULL,
             inherits = NULL) {
      ## check the parameter name
      assert_scalar(pos)
      assert_choice(pos, names(x))

      ## get the samples for this parameter
      d <- x@data[[pos]]
      ## this can be either a vector or a matrix

      ## how many parameters do we have?
      nPars <- NCOL(d)

      ## what are the names of all parameter
      ## elements?
      elements <-
        if (nPars == 1L) {
          pos
        } else {
          paste(pos,
            "[", seq_len(nPars), "]",
            sep = ""
          )
        }

      ## in case we have a vector parameter
      if (nPars > 1L) {
        ## what are the indices to be returned?
        indices <-
          if (is.null(envir)) {
            seq_along(elements)
          } else {
            assert_integer(envir)
            assert_subset(envir, seq_along(elements))
          }

        ## subset the data matrix and par names appropriately
        d <- d[, indices, drop = FALSE]
        elements <- elements[indices]

        ## and also reduce the number of parameters
        nPars <- length(indices)
      }

      ## now we can build
      ret <- data.frame(
        Iteration = seq_len(NROW(d)),
        Chain = 1L,
        Parameter =
          factor(rep(elements, each = NROW(d)),
            levels = elements
          ),
        value = as.numeric(d)
      )

      ## add the attributes
      ret <- structure(ret,
        nChains = 1L,
        nParameters = nPars,
        nIterations = x@options@iterations,
        nBurnin = x@options@burnin,
        nThin = x@options@step,
        description = elements,
        parallel = FALSE
      )
      return(ret)
    }
)


## --------------------------------------------------
## Get fitted curves from Samples
## --------------------------------------------------

#' Fit method for the Samples class
#'
#' Note this new generic function is necessary because the \code{\link{fitted}}
#' function only allows the first argument \code{object} to appear in the
#' signature. But we need also other arguments in the signature.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots passed down to the [prob()] method.
#' @return the data frame with required information (see method details)
#'
#' @export
#' @keywords methods
setGeneric("fit",
  def =
    function(object,
             model,
             data,
             ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("fit")
    },
  valueClass = "data.frame"
)


## --------------------------------------------------
## Get fitted dose-tox curve from Samples
## --------------------------------------------------

#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#'
#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-toxicity curve
#' @example examples/Sample-methods-fit.R
#'
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "GeneralModel",
      data = "Data"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      probSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        probSamples[, i] <- prob(
          dose = points[i],
          model,
          object,
          ...
        )
      }

      ## extract middle curve
      middleCurve <- apply(probSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(probSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

## --------------------------------------------------
## Get fitted dose-tox and dose-biomarker curves from Samples
## --------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, and middle,
#' lower and upper quantiles, for both the dose-tox and dose-biomarker (suffix
#' "Biomarker") curves, for all grid points (Note that currently only the grid
#' points can be used, because the DualEndpointRW models only allow that)
#'
#' @example examples/Sample-methods-fit-DualEndpoint.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "DualEndpoint",
      data = "DataDual"
    ),
  def =
    function(object,
             model,
             data,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)

      ## first obtain the dose-tox curve results from the parent method
      start <- callNextMethod(
        object = object,
        model = model,
        data = data,
        points = data@doseGrid,
        quantiles = quantiles,
        middle = middle,
        ...
      )

      ## now obtain the dose-biomarker results

      ## get the biomarker level samples
      ## at the dose grid points.
      biomLevelSamples <- biomarker(xLevel = seq_len(data@nGrid), model, samples = object)

      ## extract middle curve
      middleCurve <- apply(biomLevelSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(biomLevelSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      biomResults <- data.frame(
        middleBiomarker = middleCurve,
        lowerBiomarker = quantCurve[1, ],
        upperBiomarker = quantCurve[2, ]
      )

      ## return both, pasted together
      return(cbind(start, biomResults))
    }
)

## --------------------------------------------------
## Approximate posterior with (log) normal distribution
## --------------------------------------------------

#' Approximate posterior with (log) normal distribution
#'
#' To reproduce the resultant approximate model in the future exactly, include
#' \code{seed = xxxx} in the call to `approximate`.
#'
#' @param object the \code{\linkS4class{Samples}} object
#' @param model the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param \dots additional arguments (see methods)
#' @return a `list` containing the approximation model and, if requested, a
#' `ggplot2` object containing a graphical representation of the fitted model
#'
#' @export
#' @keywords methods
setGeneric("approximate",
  def =
    function(object, model, data, ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("approximate")
    },
  valueClass = "list"
)


##' @param points optional parameter, which gives the dose values at which
##' the approximation should rely on (default: 5 values equally spaced from
##' minimum to maximum of the dose grid)
##' @param refDose the reference dose to be used (default: median of
##' \code{points})
##' @param logNormal use the log-normal prior? (not default) otherwise, the
##' normal prior for the logistic regression coefficients is used
##' @param verbose be verbose (progress statements)? (default)
##' @param create_plot add a `ggplot2` object to the return value (default)
##'
##' @describeIn approximate Here the \dots argument can transport additional arguments for
##' \code{\link{Quantiles2LogisticNormal}}, e.g. in order to control the
##' approximation quality, etc.
##'
##' @example examples/Sample-methods-approximate.R
setMethod("approximate",
  signature =
    signature(object = "Samples"),
  def =
    function(object,
             model,
             data,
             points =
               seq(
                 from = min(data@doseGrid),
                 to = max(data@doseGrid),
                 length = 5L
               ),
             refDose = median(points),
             logNormal = FALSE,
             verbose = TRUE,
             create_plot = TRUE,
             ...) {
      # Validation
      assert_logical(logNormal)
      assert_logical(verbose)
      assert_logical(create_plot)
      assert_numeric(points)
      assert_numeric(refDose)
      ## get the required quantiles at these dose levels:
      quants <- fit(object,
        model,
        data,
        points = points,
        quantiles = c(0.025, 0.975),
        middle = median
      )

      ## get better starting values if it is already a logistic normal
      ## model
      if (is(model, "LogisticNormal") && (!logNormal)) {
        means <- sapply(
          object@data,
          mean
        )
        cov <- cov(as.data.frame(object@data))

        parstart <- c(
          means[1], means[2],
          sqrt(cov[1, 1]), sqrt(cov[2, 2]),
          cov2cor(cov)[1, 2]
        )
      } else if (is(model, "LogisticLogNormal") && logNormal) {
        datTrafo <- with(
          object@data,
          cbind(
            alpha0,
            log(alpha1)
          )
        )

        means <- colMeans(datTrafo)
        cov <- cov(datTrafo)

        parstart <- c(
          means[1], means[2],
          sqrt(cov[1, 1]), sqrt(cov[2, 2]),
          cov2cor(cov)[1, 2]
        )
      } else {
        parstart <- NULL
      }

      ## run the approx function
      quantRes <- Quantiles2LogisticNormal(
        dosegrid = quants$dose,
        refDose = refDose,
        lower = quants$lower,
        upper = quants$upper,
        median = quants$middle,
        verbose = verbose,
        parstart = parstart,
        logNormal = logNormal,
        ...
      )
      rv <- list()
      rv$model <- quantRes$model
      if (create_plot) {
        rv$plot <- tibble::as_tibble(quantRes$required) %>%
          tibble::add_column(Type = "original") %>%
          tibble::add_column(x = points) %>%
          dplyr::bind_rows(
            tibble::as_tibble(quantRes$quantiles) %>%
              tibble::add_column(Type = "approximation") %>%
              tibble::add_column(x = points)
          ) %>%
          tidyr::pivot_longer(
            c(lower, median, upper),
            names_to = "Line",
            values_to = "y"
          ) %>%
          ggplot(
            aes(
              x = x,
              y = y,
              colour = Type,
              group = interaction(Type, .data$Line),
              linetype = (.data$Line == "median")
            )
          ) +
          geom_line() +
          scale_colour_manual(
            name = " ",
            values = c("red", "blue")
          ) +
          scale_linetype_manual(
            name = " ",
            values = c("dotted", "solid"),
            labels = c("95% CI", "Median"),
            guide = guide_legend(reverse = TRUE)
          ) +
          labs(
            x = "Dose",
            y = "p(Tox)"
          ) +
          theme_light()
      }

      ## return the results
      return(rv)
    }
)

## --------------------------------------------------
## Plot dose-tox fit from a model
## --------------------------------------------------


#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{GeneralModel}} object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @example examples/Sample-methods-plot.R
#' @export
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "GeneralModel"
    ),
  def =
    function(x, y, data, ...,
             xlab = "Dose level",
             ylab = "Probability of DLT [%]",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)

      ## get the fit
      plotData <- fit(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean,
        ...
      )

      ## make the plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type,
          ),
          colour = I("red"),
        ) +
        coord_cartesian(ylim = c(0, 100)) +
        labs(
          x = xlab,
          y = ylab,
        )

      ret <- ret +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2), guide = ifelse(showLegend, "legend", "none")
        )

      return(ret)
    }
)


## --------------------------------------------------
## Special method for dual endpoint model
## --------------------------------------------------


#' Plotting dose-toxicity and dose-biomarker model fits
#'
#' When we have the dual endpoint model,
#' also the dose-biomarker fit is shown in the plot
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DualEndpoint}} object
#' @param data the \code{\linkS4class{DataDual}} object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-biomarker model fits
#'
#' @example examples/Sample-methods-plot-DualEndpoint.R
#' @export
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "DualEndpoint"
    ),
  def =
    function(x, y, data, extrapolate = TRUE, showLegend = FALSE, ...) {
      assert_logical(extrapolate)

      ## call the superclass method, to get the toxicity plot
      plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

      ## only look at these dose levels for the plot:
      xLevels <-
        if (extrapolate) {
          seq_along(data@doseGrid)
        } else {
          1:max(data@xLevel)
        }

      ## get the plot data for the biomarker plot
      functionSamples <- biomarker(xLevel = xLevels, model = y, samples = x)

      ## extract mean curve
      meanCurve <- colMeans(functionSamples)

      ## extract quantiles
      quantiles <- c(0.025, 0.975)
      quantCurve <- apply(functionSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      plotData <- data.frame(
        dose = data@doseGrid[xLevels],
        mean = meanCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## make the second plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(mean, lower, upper),
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )
      plot2 <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue")
        ) +
        labs(
          x = "Dose level",
          y = "Biomarker level"
        )

      plot2 <- plot2 +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )

      ## arrange both plots side by side
      ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
      return(ret)
    }
)


## -------------------------------------------------------------------------------------
## Get fitted dose-tox curve from Samples for 'LogisticIndepBeta' model class
## ------------------------------------------------------------------------------------
#' @describeIn fit This method return a data frame with dose, middle lower and upper quantiles
#' for the dose-DLE curve using DLE samples for \dQuote{LogisticIndepBeta} model class
#' @example examples/Samples-method-fitDLE.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "LogisticIndepBeta",
      data = "Data"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      probSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        probSamples[, i] <- prob(
          dose = points[i],
          model,
          object
        )
      }

      ## extract middle curve
      middleCurve <- apply(probSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(probSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

## -------------------------------------------------------------------------------------
## Get fitted dose-efficacy curve from Samples for 'Effloglog' model class
## ------------------------------------------------------------------------------------

#' @describeIn fit This method returns a data frame with dose, middle, lower, upper quantiles for
#' the dose-efficacy curve using efficacy samples for \dQuote{Effloglog} model class
#' @example examples/Samples-method-fitEff.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "Effloglog",
      data = "DataDual"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      ExpEffSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        ExpEffSamples[, i] <- efficacy(
          dose = points[i],
          model,
          object
        )
      }

      ## extract middle curve
      middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(ExpEffSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)
## ==========================================================================================
## --------------------------------------------------------------------
## Get fitted dose-efficacy based on the Efficacy Flexible model
## -------------------------------------------------------------
#' @describeIn fit This method returns a data frame with dose, middle, lower and upper
#' quantiles for the dose-efficacy curve using efficacy samples for \dQuote{EffFlexi}
#' model class
#' @example examples/Samples-method-fitEffFlexi.R
setMethod("fit",
  signature =
    signature(
      object = "Samples",
      model = "EffFlexi",
      data = "DataDual"
    ),
  def =
    function(object,
             model,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the dose-tox
      ## curve at the dose grid points.
      ExpEffSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      ## evaluate the probs, for all samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        ExpEffSamples[, i] <- efficacy(
          dose = points[i],
          model,
          object
        )
      }

      ## extract middle curve
      middleCurve <- apply(ExpEffSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(ExpEffSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

#' @describeIn fit This method returns a data frame with dose, middle, lower
#' and upper quantiles for the dose-efficacy curve using efficacy samples
#' for the \dQuote{LogisticLogNormalOrdinal} model class
#' @example examples/Sample-methods-fit-LogisticLogNormalOrdinal.R
setMethod(
  "fit",
  signature = signature(
    object = "Samples",
    model = "LogisticLogNormalOrdinal",
    data = "DataOrdinal"
  ),
  def = function(object,
                 model,
                 data,
                 points = data@doseGrid,
                 quantiles = c(0.025, 0.975),
                 middle = mean,
                 ...) {
    # Validation
    assert_probability_range(quantiles)
    assert_numeric(points)
    assert_function(middle)

    # Begin
    # Get samples from the dose-tox curve at the dose grid points.
    probSamples <- matrix(
      nrow = size(object),
      ncol = length(points)
    )
    # Evaluate the probs, for all samples.
    for (i in seq_along(points)) {
      # Now we want to evaluate for the following dose:
      probSamples[, i] <- prob(
        dose = points[i],
        model,
        object,
        ...
      )
    }
    # Extract middle curve
    middleCurve <- apply(probSamples, 2L, FUN = middle)
    # Extract quantiles
    quantCurve <- apply(probSamples, 2L, quantile, prob = quantiles)

    # Create the data frame...
    ret <- data.frame(
      dose = points,
      middle = middleCurve,
      lower = quantCurve[1, ],
      upper = quantCurve[2, ]
    )

    # ...and return it
    return(ret)
  }
)
## ==============================================================
## ----------------------------------------------------------------
## Get fitted values at all dose levels from gain samples
## -----------------------------------------------------------------
#' Get the fitted values for the gain values at all dose levels based on
#' a given pseudo DLE model, DLE sample, a pseudo efficacy model, a Efficacy sample
#' and data. This method returns a data frame with dose, middle, lower and upper quantiles
#' of the gain value samples
#'
#' @param DLEmodel the DLE pseudo model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the efficacy pseudo model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
#' @example examples/Samples-method-fitGain.R
setGeneric("fitGain",
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data,
             ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("fitGain")
    },
  valueClass = "data.frame"
)

#' @describeIn fitGain This method returns a data frame with dose, middle, lower, upper quantiles for
#' the gain values obtained given the DLE and the efficacy samples
#' @param points at which dose levels is the fit requested? default is the dose
#' grid
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @example examples/Samples-method-fitGain.R
setMethod("fitGain",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "Samples",
      Effmodel = "ModelEff",
      Effsamples = "Samples",
      data = "DataDual"
    ),
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data,
             points = data@doseGrid,
             quantiles = c(0.025, 0.975),
             middle = mean,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_numeric(points)

      ## first we have to get samples from the gain
      ## at the dose grid points.
      GainSamples <- matrix(
        nrow = size(DLEsamples),
        ncol = length(points)
      )

      ## evaluate the probs, for all gain samples.
      for (i in seq_along(points)) {
        ## Now we want to evaluate for the
        ## following dose:
        GainSamples[, i] <- gain(
          dose = points[i],
          DLEmodel,
          DLEsamples,
          Effmodel,
          Effsamples
        )
      }

      ## extract middle curve
      middleCurve <- apply(GainSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(GainSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        dose = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)
## ---------------------------------------------------------------------------------
## Plot the fitted dose-DLE curve with pseudo DLE model with samples
## -------------------------------------------------------------------------------
#' Plot the fitted dose-DLE curve using a \code{\linkS4class{ModelTox}} class model with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelTox}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model fit
#'
#' @example examples/Samples-method-plotModelTox.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "ModelTox"
    ),
  def =
    function(x, y, data, ...,
             xlab = "Dose level",
             ylab = "Probability of DLT [%]",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)


      ## get the fit
      plotData <- fit(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## make the plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("red"),
        ) +
        coord_cartesian(ylim = c(0, 100)) +
        labs(
          x = xlab,
          y = ylab
        )

      ret <- ret +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2), guide = ifelse(showLegend, "legend", "none")
        )

      return(ret)
    }
)


# --------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve using a pseudo efficacy model with samples
## -------------------------------------------------------------------------------------------
#' Plot the fitted dose-efficacy curve using a model from \code{\linkS4class{ModelEff}} class
#' with samples
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{ModelEff}} model class object
#' @param data the \code{\linkS4class{Data}} object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model fit
#'
#' @example examples/Samples-method-plotModelEff.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "ModelEff"
    ),
  def =
    function(x, y, data, ...,
             xlab = "Dose level",
             ylab = "Expected Efficacy",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)

      ## get the fit
      plotData <- fit(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## make the plot
      gdata <-
        with(
          plotData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper),
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue")
        ) +
        labs(
          x = xlab,
          y = ylab
        ) +
        coord_cartesian(xlim = c(0, max(data@doseGrid)))

      ret <- ret +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2), guide = ifelse(showLegend, "legend", "none")
        )

      return(ret)
    }
)

## ----------------------------------------------------------------------------------------
## Plot of fitted dose-DLE curve based on a pseudo DLE model without sample
## -------------------------------------------------------------------------------------
#' Plot of the fitted dose-tox based with a given pseudo DLE model and data without samples
#'
#' @param x the data of \code{\linkS4class{Data}} class object
#' @param y the model of the \code{\linkS4class{ModelTox}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-DLE model plot
#'
#' @example examples/Samples-method-plotModelToxNoSamples.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "Data",
      y = "ModelTox"
    ),
  def =
    function(x, y,
             xlab = "Dose level",
             ylab = "Probability of DLE",
             showLegend = TRUE, ...) {
      ## check args
      assert_logical(showLegend)

      ## Make sure the right model estimates are use with the given data
      y <- update(object = y, data = x)


      ## create data frame

      plotData <- data.frame(
        dose = x@doseGrid,
        probDLE = prob(
          dose = x@doseGrid,
          model = y
        )
      )
      ## Look for TD30 and TD35
      TD30 <- dose(
        x = 0.30,
        model = y
      )
      TD35 <- dose(
        x = 0.35,
        model = y
      )

      ## make the plot
      gdata <- with(
        plotData,
        data.frame(
          x = dose,
          y = probDLE,
          group = rep("Estimated DLE", each = nrow(plotData)),
          Type = factor(rep("Estimated DLE", nrow(plotData)), levels = "Estimated DLE")
        )
      )

      plot1 <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("red"),
          linewidth = 1.5
        ) +
        labs(
          x = xlab,
          y = ylab
        ) +
        coord_cartesian(ylim = c(0, 1)) +
        scale_linetype_manual(
          breaks = "Estimated DLE",
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )
      return(plot1)
    }
)


## ---------------------------------------------------------------------------------------------
## Plot the fitted dose-efficacy curve given a pseudo efficacy model without samples
## ----------------------------------------------------------------------------------
#' Plot of the fitted dose-efficacy based with a given pseudo efficacy model and data without samples
#'
#' @param x the data of \code{\linkS4class{DataDual}} class object
#' @param y the model of the \code{\linkS4class{ModelEff}} class object
#' @param xlab the x axis label
#' @param ylab the y axis label
#' @param showLegend should the legend be shown? (default)
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-efficacy model plot
#'
#' @example examples/Samples-method-plotModelEffNoSamples.R
#' @export
#' @keywords methods
setMethod("plot",
  signature =
    signature(
      x = "DataDual",
      y = "ModelEff"
    ),
  def =
    function(x, y, ...,
             xlab = "Dose level",
             ylab = "Expected Efficacy",
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)
      y <- update(object = y, data = x)

      ## create data frame

      plotEffData <- data.frame(
        dose = x@doseGrid,
        ExpEff = efficacy(
          dose = x@doseGrid,
          model = y
        )
      )

      ## make the second plot
      ggdata <- with(
        plotEffData,
        data.frame(
          x = dose,
          y = ExpEff,
          group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
          Type = factor(rep("Estimated Expected Efficacy", nrow(plotEffData)), levels = "Estimated Expected Efficacy")
        )
      )

      ## Get efficacy plot
      plot2 <- ggplot(data = ggdata, aes(x = x, y = y), group = group) +
        xlab("Dose Levels") +
        ylab(paste("Estimated Expected Efficacy")) +
        xlim(c(0, max(x@doseGrid))) +
        geom_line(colour = I("blue"), linewidth = 1.5)

      plot2 <- plot2 +
        geom_line(linewidth = 1.5, colour = "blue")


      return(plot2)
    }
)

## ----------------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model with samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' a DLE sample, a given efficacy pseudo model and an efficacy sample
#'
#' @param DLEmodel the dose-DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE sample of \code{\linkS4class{Samples}} class object
#' @param Effmodel the dose-efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the efficacy sample of of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param \dots not used
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the plot
#'
#' @example examples/Samples-method-plotGain.R
#' @export
#' @keywords methods
setGeneric("plotGain",
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data, ...) {
      standardGeneric("plotGain")
    }
)
#' @describeIn plotGain Standard method
setMethod("plotGain",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "Samples",
      Effmodel = "ModelEff",
      Effsamples = "Samples"
    ),
  def =
    function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, ...) {
      ## Get fitted values for probabilities of DLE at all dose levels

      plotDLEData <- fit(DLEsamples,
        model = DLEmodel,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## Get fitted values for mean efficacy values at all dose levels
      plotEffData <- fit(Effsamples,
        model = Effmodel,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## Get fitted values for gain values at all dose levels
      plotGainData <- fitGain(
        DLEmodel = DLEmodel,
        DLEsamples = DLEsamples,
        Effmodel = Effmodel,
        Effsamples = Effsamples,
        data = data
      )

      ## For each of the dose levels, take the mean for the probabilties of DLE, mean efiicacy values
      ## and gain values. Hence combine them into a data frame

      plotData <- data.frame(
        dose = rep(data@doseGrid, 3),
        values = c(
          plotDLEData$middle,
          plotEffData$middle,
          plotGainData$middle
        )
      )
      ## only the line plots for the mean value of the DLE, efficacy and gain samples
      ## at all dose levels
      gdata <- with(
        plotData,
        data.frame(
          x = dose,
          y = values,
          group = c(
            rep("p(DLE)", length(data@doseGrid)),
            rep("Mean Expected Efficacy", length(data@doseGrid)),
            rep("Gain", length(data@doseGrid))
          ),
          Type = factor("Estimate", levels = "Estimate")
        )
      )

      plot1 <- ggplot(data = gdata, aes(x = x, y = y)) +
        geom_line(aes(group = group, color = group), linewidth = 1.5) +
        scale_colour_manual(name = "curves", values = c("green3", "blue", "red")) +
        xlab("Dose Level") +
        xlim(c(0, max(data@doseGrid))) +
        ylab(paste("Values")) +
        ylim(c(min(gdata$y), max(gdata$y)))
      return(plot1)
    }
)

## ----------------------------------------------------------------------------------------------------
## Plot the gain curve using a pseudo DLE and a pseudo Efficacy model without samples
## ----------------------------------------------------------------------------------------------------
#' Plot the gain curve in addition with the dose-DLE and dose-efficacy curve using a given DLE pseudo model,
#' and a given efficacy pseudo model
#'
#' @describeIn plotGain Standard method
#' @param size (`integer`)\cr a vector of length two defining the sizes of
#' the shapes used to identify the doses with, respectively, p(DLE = 0.3) and the
#' maximum gain
#' @param shape (`integer`)\cr a vector of length two defining the shapes
#' used to identify the doses with, respectively, p(DLE = 0.3) and the maximum gain
#'
#' @example examples/Samples-method-plotGainNoSamples.R
#' @export
#' @keywords methods
setMethod("plotGain",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "missing",
      Effmodel = "ModelEff",
      Effsamples = "missing"
    ),
  def =
    function(DLEmodel, Effmodel, data, size = c(8L, 8L), shape = c(16L, 17L), ...) {
      assert_integer(size, len = 2, any.missing = FALSE, lower = 0, upper = 20)
      assert_integer(shape, len = 2, any.missing = FALSE, unique = TRUE, lower = 0, upper = 25)
      ## Make sure the model estimates are corresponds to the input data
      DLEmodel <- update(object = DLEmodel, data = data)
      Effmodel <- update(object = Effmodel, data = data)

      plotData <- data.frame(
        dose = rep(data@doseGrid, 3),
        values = c(
          prob(
            dose = data@doseGrid,
            model = DLEmodel
          ),
          efficacy(
            dose = data@doseGrid,
            model = Effmodel
          ),
          gain(
            dose = data@doseGrid,
            model_dle = DLEmodel,
            model_eff = Effmodel
          )
        )
      )
      gdata <- with(
        plotData,
        data.frame(
          x = dose,
          y = values,
          group = c(
            rep("p(DLE)", length(data@doseGrid)),
            rep("Expected Efficacy", length(data@doseGrid)),
            rep("Gain", length(data@doseGrid))
          ),
          colour = rep(c("blue", "green3", "red")),
          Type = factor("Estimate", levels = "Estimate")
        )
      )

      # if changing the line type is unacceptable, consider
      # https://stackoverflow.com/questions/25632242/filled-and-hollow-shapes-where-the-fill-color-the-line-color
      plot1 <- ggplot(data = gdata, aes(x = x, y = y)) +
        geom_line(aes(group = group, linetype = group, colour = group), linewidth = 1) +
        scale_colour_manual(
          name = "Curves",
          values = c("blue", "green3", "red")
        ) +
        scale_linetype_manual(
          name = "Curves",
          values = c("solid", "dotted", "dashed")
        ) +
        xlab("Dose Level") +
        ylab(paste("Values"))

      TD30 <- dose(x = 0.3, model = DLEmodel)

      Gainfun <- function(DOSE) {
        -gain(DOSE, model_dle = DLEmodel, model_eff = Effmodel)
      }
      Gstar <- (
        optim(
          min(data@doseGrid),
          Gainfun,
          method = "L-BFGS-B",
          lower = min(data@doseGrid),
          upper = max(data@doseGrid)
        )$par
      )
      MaxGain <- -(
        optim(
          min(data@doseGrid),
          Gainfun,
          method = "L-BFGS-B",
          lower = min(data@doseGrid),
          upper = max(data@doseGrid)
        )$value
      )

      if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
        plot1 <- plot1
        message(paste("TD30", paste(TD30, " not within dose Grid")))
      } else {
        plot1 <- plot1 +
          geom_point(
            data = data.frame(x = TD30, y = 0.3),
            aes(x = x, y = y),
            colour = "violet",
            shape = 16,
            size = 8
          ) +
          annotate(
            "text",
            label = "p(DLE=0.3)",
            x = TD30 + 1,
            y = 0.2,
            size = 5,
            colour = "violet"
          )
      }

      # Add annotated point estimates to graph
      point_data <- tibble::tibble(
        Text = NA_character_,
        X = NA_real_,
        Y = NA_real_,
        Shape = NA_real_,
        Size = NA_real_,
        Colour = NA_character_,
        .rows = 0
      )

      if ((TD30 < min(data@doseGrid)) | (TD30 > max(data@doseGrid))) {
        message(paste("TD30", paste(TD30, " not within dose Grid")))
      } else {
        point_data <- point_data %>%
          tibble::add_row(
            X = TD30,
            Y = 0.3,
            Shape = shape[1],
            Size = size[1],
            Colour = "violet",
            Text = "p(DLE=0.3)"
          )
      }
      if ((Gstar < min(data@doseGrid)) | (Gstar > max(data@doseGrid))) {
        print(paste("Gstar=", paste(Gstar, " not within dose Grid")))
      } else {
        plot1 <- plot1 +
          geom_point(
            data = data.frame(x = Gstar, y = MaxGain),
            aes(x = x, y = y),
            colour = "green3",
            shape = 17,
            size = 8
          ) +
          annotate(
            "text",
            label = "Max Gain",
            x = Gstar,
            y = MaxGain - 0.1,
            size = 5,
            colour = "green3"
          )
      }
      point_data <- point_data %>%
        tibble::add_row(
          X = Gstar,
          Y = MaxGain,
          Shape = shape[2],
          Size = size[2],
          Colour = "green3",
          Text = "Max Gain"
        )


      plot1 <- plot1 +
        geom_point(
          data = point_data,
          inherit.aes = FALSE,
          aes(
            x = .data$X,
            y = .data$Y,
            shape = as.factor(.data$Shape),
            fill = .data$Colour
          ),
          colour = point_data$Colour,
          size = point_data$Size,
        ) +
        scale_fill_manual(
          name = "Estimates",
          labels = c("p(DLE = 0.3)", "Max Gain"),
          values = point_data$Colour
        ) +
        scale_shape_discrete(
          name = "Estimates",
          labels = c("p(DLE = 0.3)", "Max Gain"),
          breaks = point_data$Shape
        ) +
        guides(
          shape = guide_legend(override.aes = list(color = c("violet", "green3")))
        ) +
        coord_cartesian(
          xlim = c(0, max(data@doseGrid)),
          ylim = c(min(gdata$y), max(gdata$y))
        )
      return(plot1)
    }
)
## ==========================================================================================

## -------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side with samples
## -----------------------------------------------------------------------------
#' Plot of the DLE and efficacy curve side by side given a DLE pseudo model,
#' a DLE sample, an efficacy pseudo model and a given efficacy sample
#'
#' @param DLEmodel the pseudo DLE model of \code{\linkS4class{ModelTox}} class object
#' @param DLEsamples the DLE samples of \code{\linkS4class{Samples}} class object
#' @param Effmodel the pseudo efficacy model of \code{\linkS4class{ModelEff}} class object
#' @param Effsamples the Efficacy samples of \code{\linkS4class{Samples}} class object
#' @param data the data input of \code{\linkS4class{DataDual}} class object
#' @param extrapolate should the biomarker fit be extrapolated to the whole
#' dose grid? (default)
#' @param showLegend should the legend be shown? (not default)
#' @param \dots additional arguments for the parent method
#' \code{\link{plot,Samples,GeneralModel-method}}
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object with the dose-toxicity and dose-efficacy model fits
#'
#' @example examples/Samples-method-plotDualResponses.R
#'
#' @export
#' @keywords methods
setGeneric("plotDualResponses",
  def =
    function(DLEmodel,
             DLEsamples,
             Effmodel,
             Effsamples,
             data, ...) {
      standardGeneric("plotDualResponses")
    }
)

#' @describeIn plotDualResponses function still to be documented
setMethod("plotDualResponses",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "Samples",
      Effmodel = "ModelEff",
      Effsamples = "Samples"
    ),
  def =
    function(DLEmodel, DLEsamples, Effmodel, Effsamples, data, extrapolate = TRUE, showLegend = FALSE, ...) {
      assert_logical(extrapolate)
      assert_logical(showLegend)
      ## Get Toxicity plot
      ## get the fit

      plotDLEData <- fit(DLEsamples,
        model = DLEmodel,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean
      )

      ## make the plot
      gdata <-
        with(
          plotDLEData,
          data.frame(
            x = rep(dose, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(plotDLEData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(plotDLEData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(plotDLEData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )

      ret1 <- gdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("red"),
        ) +
        labs(
          x = "Dose Levels",
          y = "Probability of DLE [%]"
        ) +
        coord_cartesian(ylim = c(0, 100)) +
        scale_linetype_manual(
          breaks = c(
            "Estimate",
            "95% Credible Interval"
          ),
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )
      ## only look at these dose levels for the plot:

      xLevels <- if (extrapolate) {
        seq_along(data@doseGrid)
      } else {
        1:max(data@xLevel)
      }

      ## get the plot data for the efficacy
      functionSamples <- matrix(
        nrow = size(Effsamples),
        ncol = length(xLevels)
      )
      ## evaluate the efficacy for all samples
      for (i in seq_along(xLevels)) {
        ## Now we want to evaluate for the following dose
        functionSamples[, i] <- efficacy(
          dose = data@doseGrid[xLevels[i]],
          model = Effmodel,
          samples = Effsamples
        )
      }
      ## extract mean curve
      meanCurve <- colMeans(functionSamples)

      ## extract quantiles
      quantiles <- c(0.025, 0.975)
      quantCurve <- apply(functionSamples, 2L, quantile, prob = quantiles)

      ## now create the data frame
      plotEffData <- data.frame(
        dose = data@doseGrid[xLevels],
        mean = meanCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )
      ## make the second plot
      ggdata <- with(plotEffData, data.frame(
        x = rep(dose, 3),
        y = c(mean, lower, upper),
        group =
          rep(c("mean", "lower", "upper"),
            each = nrow(plotEffData)
          ),
        Type =
          factor(
            c(
              rep(
                "Estimate",
                nrow(plotEffData)
              ),
              rep(
                "95% Credible Interval",
                nrow(plotEffData) * 2
              )
            ),
            levels =
              c(
                "Estimate",
                "95% Credible Interval"
              )
          )
      ))

      plot2 <- ggdata %>% ggplot() +
        geom_line(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue"),
        ) +
        labs(
          x = "Dose level",
          y = "Expected Efficacy"
        ) +
        scale_linetype_manual(
          breaks =
            c(
              "Estimate",
              "95% Credible Interval"
            ),
          values = c(1, 2),
          guide = ifelse(showLegend, "legend", "none")
        )

      ## arrange both plots side by side
      ret <- gridExtra::arrangeGrob(ret1, plot2, ncol = 2)
      return(ret)
    }
)

## ------------------------------------------------------------------------------
## Plot of the DLE and efficacy curve sides by side without  samples
## -----------------------------------------------------------------------------
#' Plot of the dose-DLE and dose-efficacy curve side by side given a DLE pseudo model
#' and a given pseudo efficacy model without DLE and efficacy samples
#'
#' @describeIn plotDualResponses Plot the DLE and efficacy curve side by side given a DLE model
#' and an efficacy model without any samples
#'
#' @example examples/Samples-method-plotDualResponsesNoSamples.R
#'
#' @export
#' @keywords methods
setMethod("plotDualResponses",
  signature =
    signature(
      DLEmodel = "ModelTox",
      DLEsamples = "missing",
      Effmodel = "ModelEff",
      Effsamples = "missing"
    ),
  def =
    function(DLEmodel, Effmodel, data, ...) {
      ## Get Toxicity plot
      ## get the fit


      ## Make sure the model estimates are corresponds to the input data
      DLEmodel <- update(object = DLEmodel, data = data)
      Effmodel <- update(object = Effmodel, data = data)


      plotDLEData <- data.frame(
        dose = data@doseGrid,
        probDLE = prob(
          dose = data@doseGrid,
          model = DLEmodel
        )
      )
      ## make the plot
      gdata <- with(
        plotDLEData,
        data.frame(
          x = dose,
          y = probDLE,
          group = rep("Estimated DLE", each = nrow(plotDLEData)),
          Type = factor(rep("Estimated DLE", nrow(plotDLEData)), levels = "Estimated DLE")
        )
      )

      plot1 <- ggplot(data = gdata, aes(x = x, y = y), group = group) +
        xlab("Dose Levels") +
        ylab(paste("Probability of DLE")) +
        ylim(c(0, 1)) +
        xlim(c(0, max(data@doseGrid))) +
        geom_line(colour = I("red"), linewidth = 1.5)


      plot1 <- plot1 +
        geom_line(linewidth = 1.5, colour = "red")

      ## only look at these dose levels for the plot:

      ## get the plot data for the efficacy
      plotEffData <- data.frame(
        dose = data@doseGrid,
        ExpEff = efficacy(
          dose = data@doseGrid,
          model = Effmodel
        )
      )

      ## make the second plot
      ggdata <- with(
        plotEffData,
        data.frame(
          x = dose,
          y = ExpEff,
          group = rep("Estimated Expected Efficacy", each = nrow(plotEffData)),
          Type = factor(rep("Estimated Expected Efficacy", nrow(plotEffData)), levels = "Estimated Expected Efficacy")
        )
      )

      ## Get efficacy plot
      plot2 <- ggplot(data = ggdata, aes(x = x, y = y), group = group) +
        xlab("Dose Levels") +
        ylab(paste("Estimatimated Expected Efficacy")) +
        xlim(c(0, max(data@doseGrid))) +
        geom_line(colour = I("blue"), linewidth = 1.5)

      plot2 <- plot2 +
        geom_line(linewidth = 1.5, colour = "blue")

      ## arrange both plots side by side
      ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
      return(ret)
    }
)
## =======================================================================================================

## ----------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -----------------------------------------------------------------
#' Get the fitted DLT free survival (piecewise exponential model).
#' This function returns a data frame with dose, middle, lower and upper
#' quantiles for the `PEM` curve. If hazard=TRUE,
#' @param object mcmc samples
#' @param model the mDA-CRM model
#' @param data the data input, a \code{\linkS4class{DataDA}} class object
#' @param quantiles the quantiles to be calculated (default: 0.025 and
#' 0.975)
#' @param middle the function for computing the middle point. Default:
#' \code{\link{mean}}
#' @param hazard should the the hazard over time be plotted based on the `PEM`? (not default)
#'   Otherwise ...
#' @param \dots additional arguments for methods
#'
#' @export
#' @keywords methods
setGeneric("fitPEM",
  def =
    function(object,
             model,
             data,
             quantiles = c(0.025, 0.975),
             middle = mean,
             hazard = FALSE,
             ...) {
      ## there should be no default method,
      ## therefore just forward to next method!
      standardGeneric("fitPEM")
    },
  valueClass = "data.frame"
)


#' Likelihood of DLTs in each interval
#'
#' This is a helper function for the `fitPEM` methods below.
#'
#' @param lambda the vector of piecewise hazards
#' @param Tmax the end of the time interval for DLTs
#' @return vector with the probabilities for DLTs within the intervals.
#'
#' @keywords internal
DLTLikelihood <- function(lambda,
                          Tmax) {
  npiece <- length(lambda)
  h <- seq(from = 0L, to = Tmax, length = npiece + 1)

  # Length of each time interval;
  sT <- rep(0, npiece)


  for (i in 1:npiece) {
    sT[i] <- h[i + 1] - h[i]
  }


  # calculate the exponential part of the distribution:
  s_ij <- function(t, j) {
    if (t > h[j]) {
      min(t - h[j], h[j + 1] - h[j])
    } else {
      0
    }
  }


  # The cumulative hazard function
  expNmu <- function(t) {
    ret <- 1
    for (j in 1:npiece) {
      ret <- ret * exp(-lambda[j] * s_ij(t, j))
    }
    return(ret)
  }

  # CDF of the piecewise exponential
  piece_exp_cdf <- function(x) {
    1 - expNmu(x)
  }

  DLTFreeS <- function(x) {
    (expNmu(x) - expNmu(Tmax)) / piece_exp_cdf(Tmax)
  }

  pDLT <- rep(0, npiece + 1)

  for (i in 1:(npiece)) {
    pDLT[i] <- DLTFreeS(h[i]) - DLTFreeS(h[i + 1])
  }

  return(pDLT)
}

## --------------------------------------------------------------------
## Get fitted DLT free survival (piecewise exponential model) based on
## the DA-CRM model
## -------------------------------------------------------------
#' @describeIn fitPEM This method works for the \code{\linkS4class{DALogisticLogNormal}}
#' model class.
#' @example examples/Samples-method-fitPEM-DALogisticLogNormal.R
setMethod("fitPEM",
  signature =
    signature(
      object = "Samples",
      model = "DALogisticLogNormal",
      data = "DataDA"
    ),
  def =
    function(object,
             model,
             data,
             quantiles = c(0.025, 0.975),
             middle = mean,
             hazard = FALSE,
             ...) {
      ## some checks
      assert_probability_range(quantiles)
      assert_logical(hazard)
      ## Plot points
      points <- seq(0, data@Tmax, length = model@npiece + 1)
      ## first we have to get samples from the PEM
      ## at intercept points and 2 middel points between
      ## intercepts.
      PEMSamples <- matrix(
        nrow = size(object),
        ncol = length(points)
      )

      i_max <- max(seq_along(points))
      ## evaluate the probs, for all samples.

      # The PEM
      if (hazard == FALSE) {
        PEMSamples <- t(apply(object@data$lambda, 1, function(x) {
          fit <- DLTLikelihood(x, data@Tmax)
          return(fit)
        }))
      } else if (hazard == TRUE) {
        for (i in seq_along(points)) {
          if (i == i_max) {
            PEMSamples[, i_max] <- object@data$lambda[, model@npiece]
          } else {
            PEMSamples[, i] <- object@data$lambda[, i]
          }
        }
      }

      ## extract middle curve
      middleCurve <- apply(PEMSamples, 2L, FUN = middle)

      ## extract quantiles
      quantCurve <- apply(PEMSamples, 2L, quantile,
        prob = quantiles
      )

      ## now create the data frame
      ret <- data.frame(
        time = points,
        middle = middleCurve,
        lower = quantCurve[1, ],
        upper = quantCurve[2, ]
      )

      ## return it
      return(ret)
    }
)

## =======================================================================================================


## --------------------------------------------------
## Plot survival curve fit over time
## --------------------------------------------------

## todo: add example file
#' Plotting dose-toxicity model fits
#'
#' @param x the \code{\linkS4class{Samples}} object
#' @param y the \code{\linkS4class{DALogisticLogNormal}} object
#' @param data the \code{\linkS4class{DataDA}} object
#' @param hazard see \code{\link{fitPEM}} for the explanation
#' @param \dots not used
#' @param showLegend should the legend be shown? (default)
#' @return This returns the \code{\link[ggplot2]{ggplot}}
#' object for the dose-toxicity model fit
#'
#' @export
setMethod("plot",
  signature =
    signature(
      x = "Samples",
      y = "DALogisticLogNormal"
    ),
  def =
    function(x, y, data, hazard = FALSE, ...,
             showLegend = TRUE) {
      ## check args
      assert_logical(showLegend)
      assert_logical(hazard)

      ## call the superclass method, to get the toxicity plot
      plot1 <- callNextMethod(x, y, data, showLegend = showLegend, ...)

      ## get the fit
      fitData <- fitPEM(x,
        model = y,
        data = data,
        quantiles = c(0.025, 0.975),
        middle = mean,
        hazard = hazard
      )

      ## make the plot
      Tpoints <- seq(0, data@Tmax, length = y@npiece + 1)
      plotData <-
        with(
          fitData,
          data.frame(
            x = rep(Tpoints, 3),
            y = c(middle, lower, upper) * 100,
            group =
              rep(c("mean", "lower", "upper"),
                each = nrow(fitData)
              ),
            Type =
              factor(
                c(
                  rep(
                    "Estimate",
                    nrow(fitData)
                  ),
                  rep(
                    "95% Credible Interval",
                    nrow(fitData) * 2
                  )
                ),
                levels =
                  c(
                    "Estimate",
                    "95% Credible Interval"
                  )
              )
          )
        )
      plot2 <- plotData %>% ggplot() +
        geom_step(
          aes(
            x = x,
            y = y,
            group = group,
            linetype = Type
          ),
          colour = I("blue")
        ) +
        labs(
          x = "Time",
          y = if (hazard) "Hazard rate*100" else "Probability of DLT [%]"
        ) +
        coord_cartesian(
          ylim = if (hazard) range(plotData$y) else c(0, 100)
        )

      ret <- gridExtra::arrangeGrob(plot1, plot2, ncol = 2)
      return(ret)
    }
)


## =======================================================================================================

# tidy ----

## Samples

## tidy-Samples ----

#' @rdname tidy
#' @aliases tidy-Samples
#' @example examples/Samples-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Samples"),
  definition = function(x, ...) {
    rv <- lapply(
      slotNames(x),
      function(nm) {
        if (nm == "data") {
          lapply(
            names(x@data),
            function(nm) {
              as_tibble(get(x, nm))
            }
          ) %>%
            dplyr::bind_rows() %>%
            tidyr::pivot_wider(
              names_from = Parameter,
              values_from = value
            ) %>%
            dplyr::bind_cols(h_handle_attributes(get(x, names(x@data)[1])))
        } else {
          slot(x, nm) %>%
            tidy() %>%
            dplyr::bind_cols()
        }
      }
    )
    names(rv) <- c("data", "options")
    rv <- rv %>% h_tidy_class(x)
    rv
  }
)

# NextBest ----

#' Internal Helper Functions for Validation of [`NextBest`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`NextBest`] or inherited classes and therefore not exported.
#'
#' @name v_next_best
#' @param object (`NextBest`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_next_best validates that the [`NextBestMTD`] object
#'   contains valid `target` probability and `derive` function.
v_next_best_mtd <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRM`] object
#'   contains valid `target` probability, `overdose` and `max_overdose_prob`
#'   probability ranges.
v_next_best_ncrm <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestNCRMLoss`] object
#'   contains valid objects.
v_next_best_ncrm_loss <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target, bounds_closed = FALSE),
    "target has to be a probability range excluding 0 and 1"
  )

  is_overdose_ok <- test_probability_range(object@overdose, bounds_closed = TRUE)
  v$check(is_overdose_ok, "overdose has to be a probability range")

  is_unacceptable_ok <- test_probability_range(object@unacceptable, bounds_closed = TRUE)
  v$check(is_unacceptable_ok, "unacceptable has to be a probability range")

  if (is_overdose_ok && is_unacceptable_ok) {
    v$check(
      object@overdose[2] <= object@unacceptable[1],
      "lower bound of unacceptable has to be >= than upper bound of overdose"
    )
  }
  if (is_unacceptable_ok) {
    losses_len <- ifelse(all(object@unacceptable == c(1, 1)), 3L, 4L)
    v$check(
      test_numeric(object@losses, lower = 0, finite = TRUE, any.missing = FALSE, len = losses_len),
      "losses must be a vector of non-negative numbers of length 3 if unacceptable is c(1, 1), otherwise 4"
    )
  }
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestDualEndpoint`] object
#'   contains valid probability objects.
v_next_best_dual_endpoint <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@target_relative),
    "target_relative must be a flag"
  )
  if (isTRUE(object@target_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when target_relative is TRUE"
    )
  } else {
    v$check(
      test_range(object@target),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability_range(object@overdose),
    "overdose has to be a probability range"
  )
  v$check(
    test_probability(object@max_overdose_prob, bounds_closed = FALSE),
    "max_overdose_prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@target_thresh),
    "target_thresh must be a probability value from [0, 1] interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMinDist`] object
#'   contains valid `target` object.
v_next_best_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestInfTheory`] object
#'   contains valid `target` and `asymmetry` objects.
v_next_best_inf_theory <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@asymmetry, finite = TRUE) && h_in_range(object@asymmetry, c(0, 2), FALSE),
    "asymmetry must be a number from (0, 2) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTD`] object
#'   contains valid `prob_target_drt` and `prob_target_eot` probabilities.
v_next_best_td <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@prob_target_drt, bounds_closed = FALSE),
    "prob_target_drt must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob_target_eot, bounds_closed = FALSE),
    "prob_target_eot must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestTDsamples`] object
#'   contains valid `derive` function.
v_next_best_td_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestMaxGainSamples`] object
#'   contains valid `derive` and `mg_derive` functions.
v_next_best_max_gain_samples <- function(object) {
  v <- Validate()
  v$check(
    test_function(object@derive, nargs = 1),
    "derive must have a single argument"
  )
  v$check(
    test_number(object@derive(1:5)),
    "derive must accept numerical vector as an argument and return a number"
  )
  v$check(
    test_function(object@mg_derive, nargs = 1),
    "mg_derive must have a single argument"
  )
  v$check(
    test_number(object@mg_derive(1:5)),
    "mg_derive must accept numerical vector as an argument and return a number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDLTE`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_lte <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestProbMTDMinDist`] object
#'   contains valid `target` probability and `method` string value.
v_next_best_prob_mtd_min_dist <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$result()
}

# Increments ----

#' Internal Helper Functions for Validation of [`Increments`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Increments`] or inherited classes and therefore not exported.
#'
#' @name v_increments
#' @param object (`Increments`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_increments validates that the [`IncrementsRelative`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0, finite = TRUE, any.missing = FALSE, unique = TRUE, sorted = TRUE
    ),
    "intervals has to be a numerical vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(object@increments, finite = TRUE, any.missing = FALSE, len = length(object@intervals)),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeParts`] object
#'   contains valid `dlt_start` and `clean_start` parameters.
v_increments_relative_parts <- function(object) {
  v <- Validate()
  is_dlt_start_ok <- test_int(object@dlt_start)
  v$check(is_dlt_start_ok, "dlt_start must be an integer number")
  if (is_dlt_start_ok) {
    v$check(
      test_int(object@clean_start, lower = object@dlt_start),
      "clean_start must be an integer number and it must be >= dlt_start"
    )
  }
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsRelativeDLT`] object
#'   contains valid `intervals` and `increments` parameters.
v_increments_relative_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@intervals, lower = 0, any.missing = FALSE, unique = TRUE, sorted = TRUE),
    "intervals has to be an integer vector with unique, finite, non-negative and sorted non-missing values"
  )
  v$check(
    test_numeric(object@increments, finite = TRUE, any.missing = FALSE, len = length(object@intervals)),
    "increments has to be a numerical vector of the same length as `intervals` with finite values"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsDoseLevels`] object
#'   contains valid `levels` and `basis_level` option.
v_increments_dose_levels <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@levels, lower = .Machine$double.xmin),
    "levels must be scalar positive integer"
  )
  v$check(
    test_string(object@basis_level, pattern = "^last$|^max$"),
    "basis_level must be either 'last' or 'max'"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsHSRBeta`]
#'   object contains valid probability target, threshold and shape parameters.
v_increments_hsr_beta <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$check(
    test_number(object@a, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter a must be a positive scalar"
  )
  v$check(
    test_number(object@b, lower = .Machine$double.xmin, finite = TRUE),
    "Beta distribution shape parameter b must be a positive scalar"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsMin`]
#'   object contains a list with `Increments` objects.
v_increments_min <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@increments_list, test_class, "Increments")),
    "all elements in increments_list must be of Increments class"
  )
  v$result()
}

# Stopping ----

#' Internal Helper Functions for Validation of [`Stopping`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`Stopping`] or inherited classes and therefore not exported.
#'
#' @name v_stopping
#' @param object (`Stopping`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_stopping validates that the [`StoppingCohortsNearDose`]
#'   object contains valid `nCohorts` and `percentage` parameters.
v_stopping_cohorts_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingPatientsNearDose`]
#'   object contains valid `nPatients` and `percentage` parameters.
v_stopping_patients_near_dose <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$check(
    test_probability(object@percentage / 100),
    "percentage must be a number between 0 and 100"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinCohorts`]
#'   object contains valid `nCohorts` parameter.
v_stopping_min_cohorts <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nCohorts, lower = .Machine$double.xmin),
    "nCohorts must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMinPatients`]
#'   object contains valid `nPatients` parameter.
v_stopping_min_patients <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@nPatients, lower = .Machine$double.xmin),
    "nPatients must be positive integer scalar"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetProb`]
#'   object contains valid `target` and `prob` parameters.
v_stopping_target_prob <- function(object) {
  v <- Validate()
  v$check(
    test_probability_range(object@target),
    "target has to be a probability range"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDdistribution`]
#'   object contains valid `target`, `thresh` and `prob` parameters.
v_stopping_mtd_distribution <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh, bounds_closed = FALSE),
    "thresh must be a probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingMTDCV`] object
#'   contains valid probability target and percentage threshold.
v_stopping_mtd_cv <- function(object) {
  v <- Validate()
  v$check(
    test_probability(object@target, bounds_closed = FALSE),
    "target must be probability value from (0, 1) interval"
  )
  v$check(
    test_probability(object@thresh_cv / 100, bounds_closed = c(FALSE, TRUE)),
    "thresh_cv must be percentage > 0"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTargetBiomarker`] object
#'   contains valid `target`, `is_relative` and `prob`slots.
v_stopping_target_biomarker <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@is_relative),
    "is_relative must be a flag"
  )
  if (isTRUE(object@is_relative)) {
    v$check(
      test_probability_range(object@target),
      "target has to be a probability range when is_relative flag is 'TRUE'"
    )
  } else {
    v$check(
      test_range(object@target, finite = TRUE),
      "target must be a numeric range"
    )
  }
  v$check(
    test_probability(object@prob, bounds_closed = FALSE),
    "prob must be a probability value from (0, 1) interval"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingList`] object
#'   contains valid `stop_list`, `summary` slots.
v_stopping_list <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  is_summary_ok <- test_function(object@summary, nargs = 1)
  v$check(
    is_summary_ok,
    "summary must be a function that accepts a single argument, without ..."
  )
  if (is_summary_ok) {
    summary_res <- object@summary(
      rep(c(TRUE, FALSE), length.out = length(object@stop_list))
    )
    v$check(
      test_flag(summary_res),
      "summary must accept a logical vector of the same length as 'stop_list' and return a boolean value"
    )
  }
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingAll`] object
#'   contains valid `stop_list` slot.
v_stopping_all <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@stop_list, test_class, "Stopping")),
    "every stop_list element must be of class 'Stopping'"
  )
  v$result()
}

#' @describeIn v_stopping validates that the [`StoppingTDCIRatio`] object
#'   contains valid `target_ratio` and  `prob_target` slots.
v_stopping_tdci_ratio <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@target_ratio, lower = .Machine$double.xmin, finite = TRUE),
    "target_ratio must be a positive number"
  )
  v$check(
    test_probability(object@prob_target),
    "prob_target must be a probability value from [0, 1] interval"
  )
  v$result()
}

# CohortSize ----

#' Internal Helper Functions for Validation of [`CohortSize`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`CohortSize`] or inherited classes and therefore not exported.
#'
#' @name v_cohort_size
#' @param object (`CohortSize`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_cohort_size validates that the [`CohortSizeRange`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_range <- function(object) {
  v <- Validate()
  v$check(
    test_numeric(
      object@intervals,
      lower = 0, finite = TRUE, any.missing = FALSE, min.len = 1, unique = TRUE, sorted = TRUE
    ),
    "intervals must be a numeric vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0, any.missing = FALSE, len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeDLT`] object
#'   contains valid `intervals` and  `cohort_size` slots.
v_cohort_size_dlt <- function(object) {
  v <- Validate()
  v$check(
    test_integer(
      object@intervals,
      lower = 0, any.missing = FALSE, min.len = 1, unique = TRUE, sorted = TRUE
    ),
    "intervals must be an integer vector with non-negative, sorted (asc.) and unique values"
  )
  v$check(
    test_integer(
      object@cohort_size,
      lower = 0, any.missing = FALSE, len = length(object@intervals)
    ),
    "cohort_size must be an integer vector of the same length as intervals, containing non-negative values only"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeConst`] object
#'   contains valid `size` slot.
v_cohort_size_const <- function(object) {
  v <- Validate()
  v$check(
    test_int(object@size, lower = 0),
    "size needs to be a non-negative scalar"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeParts`] object
#'   contains valid `sizes` slot.
v_cohort_size_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@cohort_sizes, lower = .Machine$double.xmin, any.missing = FALSE, len = 2),
    "cohort_sizes needs to be an integer vector of length 2 with all elements positive"
  )
  v$result()
}

#' @describeIn v_cohort_size validates that the [`CohortSizeMax`] object
#'   contains valid `cohort_sizes` slot.
v_cohort_size_max <- function(object) {
  v <- Validate()
  v$check(
    test_list(object@cohort_sizes, types = "CohortSize", any.missing = FALSE, min.len = 2, unique = TRUE),
    "cohort_sizes must be a list of CohortSize (unique) objects only and be of length >= 2"
  )
  v$result()
}

# SafetyWindow ----

#' Internal Helper Functions for Validation of [`SafetyWindow`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`SafetyWindow`] or inherited classes and therefore not exported.
#'
#' @name v_safety_window
#' @param object (`SafetyWindow`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_safety_window validates that the [`SafetyWindowSize`] object
#'   contains valid slots.
v_safety_window_size <- function(object) {
  v <- Validate()
  v$check(
    test_list(object@gap, types = "integer", any.missing = FALSE, min.len = 1),
    "gap must be a list of length >= 1 with integer vectors only"
  )
  v$check(
    all(sapply(object@gap, test_integer, lower = 0, any.missing = FALSE, min.len = 1)),
    "every element in gap list has to be an integer vector with non-negative and non-missing values"
  )
  pg_len <- length(object@gap)
  v$check(
    test_integer(
      object@size,
      lower = .Machine$double.xmin, any.missing = FALSE, len = pg_len, unique = TRUE, sorted = TRUE
    ),
    "size has to be an integer vector, of the same length as gap, with positive, unique and sorted non-missing values"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_safety_window validates that the [`SafetyWindowConst`] object
#'   contains valid slots.
v_safety_window_const <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@gap, lower = 0, any.missing = FALSE),
    "gap has to be an integer vector with non-negative and non-missing elements"
  )
  v$check(
    test_int(object@follow, lower = .Machine$double.xmin),
    "follow has to be a positive integer number"
  )
  v$check(
    test_int(object@follow_min, lower = .Machine$double.xmin),
    "follow_min has to be a positive integer number"
  )
  v$result()
}

#' @describeIn v_next_best validates that the [`NextBestOrdinal`] object
#'   contains valid `grade` and standard `NextBest` rule.
v_next_best_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "NextBest"),
    "rule must be a NextBest object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`IncrementsOrdinal`] object
#'   contains valid `grade` and standard `Increments` rule.
v_increments_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "Increments"),
    "rule must be a Increments object"
  )
  v$result()
}

#' @describeIn v_increments validates that the [`CohortSizeOrdinal`] object
#'   contains valid `grade` and standard `CohortSize` rule.
v_cohort_size_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@grade, lower = 1),
    "grade must be a positive integer"
  )
  v$check(
    test_class(object@rule, "CohortSize"),
    "rule must be a CohortSize object"
  )
  v$result()
}

#' Internal Helper Functions for Validation of [`GeneralData`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralData`] or inherited classes and therefore not exported.
#'
#' @name v_data_objects
#' @param object (`GeneralData`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_data_objects validates that the [`GeneralData`]
#'   object contains unique `ID`, non-negative `cohort` indices and
#'   `ID` and `cohort` vectors are of the same length `nObs`.
v_general_data <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObs)) {
    return("nObs must be of type integer of length 1")
  }
  v$check(
    test_integer(object@ID, len = object@nObs, any.missing = FALSE, unique = TRUE, null.ok = TRUE),
    "ID must be of type integer and length nObs and unique"
  )
  v$check(
    test_integer(object@cohort, lower = 0L, len = object@nObs, any.missing = FALSE, sorted = TRUE),
    "cohort must be of type integer and length nObs and contain non-negative, sorted values"
  )
  v$result()
}

#' @describeIn v_data_objects helper function which verifies whether
#'   the `dose` values are unique in each and every different `cohort`.
#' @param dose (`numeric`)\cr dose values.
#' @param cohort (`integer`)\cr cohort indices parallel to `doses`.
#' @return `TRUE` if `dose` is unique per `cohort`, otherwise `FALSE`.
h_doses_unique_per_cohort <- function(dose, cohort) {
  assert_numeric(dose)
  assert_integer(cohort)

  num_doses_per_cohort <- tapply(
    X = dose,
    INDEX = cohort,
    FUN = function(d) length(unique(d))
  )
  all(num_doses_per_cohort == 1L)
}

#' Helper Function performing validation Common to Data and DataOrdinal
#'
#' @rdname h_validate_common_data_slots
#' @param object (`Data` or `DataOrdinal`)\cr the object to be validated
#' @returns a `Validate` object containing the result of the validation
h_validate_common_data_slots <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@x, len = object@nObs, any.missing = FALSE),
    "Doses vector x must be of type double and length nObs"
  )
  v$check(
    test_double(object@doseGrid, len = object@nGrid, any.missing = FALSE, unique = TRUE, sorted = TRUE),
    "doseGrid must be of type double and length nGrid and contain unique, sorted values"
  )
  v$check(
    test_int(object@nGrid),
    "Number of dose grid values nGrid must be scalar integer"
  )
  v$check(
    test_integer(object@xLevel, len = object@nObs, any.missing = FALSE),
    "Levels xLevel for the doses the patients have been given must be of type integer and length nObs"
  )
  v$check(
    test_flag(object@placebo),
    "The placebo flag must be scalar logical"
  )
  v$check(
    test_subset(object@x, object@doseGrid),
    "Dose values in x must be from doseGrid"
  )
  v$check(
    h_all_equivalent(object@x, object@doseGrid[object@xLevel]),
    "x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
  )
  if (object@placebo) {
    is_placebo <- object@x == object@doseGrid[1]
    v$check(
      test_set_equal(object@cohort, object@cohort[!is_placebo]),
      "A cohort with only placebo is not allowed"
    )
    v$check(
      h_doses_unique_per_cohort(dose = object@x[!is_placebo], cohort = object@cohort[!is_placebo]),
      "There must be only one dose level, other than placebo, per cohort"
    )
  } else {
    v$check(
      h_doses_unique_per_cohort(dose = object@x, cohort = object@cohort),
      "There must be only one dose level per cohort"
    )
  }
  v
}

#' @describeIn v_data_objects validates that the [`Data`] object contains
#'   valid elements with respect to their types, dependency and length.
v_data <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(object@y, lower = 0, upper = 1, len = object@nObs, any.missing = FALSE),
    "DLT vector y must be nObs long and contain 0 or 1 integers only"
  )

  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDual`] object
#' contains valid biomarker vector with respect to its type and the length.
v_data_dual <- function(object) {
  v <- Validate()
  v$check(
    test_double(object@w, len = object@nObs, any.missing = FALSE),
    "Biomarker vector w must be of type double and length nObs"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataParts`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_parts <- function(object) {
  v <- Validate()
  v$check(
    test_integer(object@part, lower = 1, upper = 2, len = object@nObs, any.missing = FALSE),
    "vector part must be nObs long and contain 1 or 2 integers only"
  )
  v$check(
    test_int(object@nextPart, lower = 1, upper = 2),
    "nextPart must be integer scalar 1 or 2"
  )
  v$check(
    test_numeric(object@part1Ladder, any.missing = FALSE, sorted = TRUE, unique = TRUE),
    "part1Ladder must be of type double and contain unique, sorted values"
  )
  v$check(
    test_subset(object@part1Ladder, object@doseGrid),
    "part1Ladder must have all entries from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataMixture`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_mixture <- function(object) {
  v <- Validate()

  # In if clause so that below test_* won't fail.
  if (!test_int(object@nObsshare)) {
    return("nObsshare must be of type integer of length 1")
  }
  v$check(
    test_numeric(object@xshare, len = object@nObsshare, any.missing = FALSE),
    "Dose vector xshare must be of type double and length nObsshare"
  )
  v$check(
    test_integer(object@yshare, lower = 0, upper = 1, len = object@nObsshare, any.missing = FALSE),
    "DLT vector yshare must be nObsshare long and contain 0 or 1 integers only"
  )
  v$check(
    test_subset(object@xshare, object@doseGrid),
    "Dose values in xshare must be from doseGrid"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataDA`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_da <- function(object) {
  v <- Validate()
  # In if clause so that below test_* won't fail.
  if (!(test_number(object@Tmax) && object@Tmax > 0)) {
    return("DLT window Tmax must be of type double of length 1 and greater than 0")
  }
  v$check(
    test_numeric(object@u, upper = object@Tmax, len = object@nObs, any.missing = FALSE) &&
      all(object@u > 0),
    "u must be of type double, nObs length, non-negative and not greater than Tmax"
  )
  v$check(
    test_numeric(object@t0, lower = 0, len = object@nObs, any.missing = FALSE, sorted = TRUE),
    "t0 must be of type double, nObs length, sorted non-negative"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataOrdinal`] object
#' contains valid elements with respect to their types, dependency and length.
v_data_ordinal <- function(object) {
  v <- h_validate_common_data_slots(object)
  v$check(
    test_integer(object@y, lower = 0, upper = length(object@yCategories) - 1, len = object@nObs, any.missing = FALSE),
    "DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
  )
  v$check(
    length(unique(names(object@yCategories))) == length(names(object@yCategories)),
    "yCategory labels must be unique"
  )
  v$result()
}

#' @describeIn v_data_objects validates that the [`DataGrouped`] object
#'   contains valid group information.
v_data_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_factor(
      object@group,
      levels = c("mono", "combo"),
      len = object@nObs,
      any.missing = FALSE
    ),
    "group must be factor with levels mono and combo of length nObs without missings"
  )
  v$result()
}

# Validate-class ----

#' `Validate`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The [`Validate`] class is a Reference Class
#' to help programming validation for new S4 classes.
#'
#' @details Starting from an empty `msg` vector, with each check
#'   that is returning `FALSE` the vector gets a new element - the string
#'   explaining the failure of the validation.
#'
#' @name Validate
#' @field msg (`character`)\cr the cumulative messages.
#'
Validate <- setRefClass(
  Class = "Validate",
  fields = list(msg = "character"),
  methods = list(
    check = function(test, string = "") {
      "Check whether the \\code{test} is \\code{TRUE}; if so, return \\code{NULL}.
      Otherwise, add the \\code{string} message into the cumulative messages vector \\code{msg}."
      assert_flag(test)
      assert_string(string)
      if (test) {
        NULL
      } else {
        msg <<- c(msg, string)
      }
    },
    result = function() {
      "Return either cumulative messages vector \\code{msg}
      (which contains the error messages from all the checks),
      or \\code{NULL}, if \\code{msg} is empty (i.e. all the checks were successful)."
      if (length(msg) > 0) {
        msg
      } else {
        TRUE
      }
    }
  )
)

# positive_number-class ----

#' `positive_number`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' The [`positive_number`] class is a class to store not `NULL`, non `NA`,
#' finite and strictly positive numerical value. It is mainly used to store
#' reference dose value in model classes.
#'
#' @name positive_number
#'
positive_number <- setClass(
  Class = "positive_number",
  contains = "numeric",
  validity = function(object) {
    v <- Validate()
    v$check(
      test_number(object, finite = TRUE) && object > 0,
      "Object's value must be strictly positive"
    )
    v$result()
  }
)

# nolint start

##' Helper function for value matching with tolerance
##'
##' This is a modified version of \code{match} that supports tolerance.
##'
##' @param x the values to be matched
##' @param table the values to be matched against
##' @return A vector of the same length as \code{x} or
##'  empty vector if \code{table} is empty.
##'
##' @export
##' @keywords programming
match_within_tolerance <- function(x, table) {
  if (length(table) == 0) {
    return(integer())
  }

  as.integer(sapply(x, function(.x) {
    which(sapply(table, function(.table) {
      isTRUE(all.equal(.x, .table,
        tolerance = 1e-10,
        check.names = FALSE,
        check.attributes = FALSE
      ))
    }))[1]
  }))
}

##' checks for whole numbers (integers)
##'
##' @param x the numeric vector
##' @param tol the tolerance
##' @return TRUE or FALSE for each element of x
##'
##' @keywords internal
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
  abs(x - round(x)) < tol
}


##' Safe conversion to integer vector
##'
##' @param x the numeric vector
##' @return the integer vector
##'
##' @keywords internal
safeInteger <- function(x) {
  testres <- is.wholenumber(x)
  if (!all(testres)) {
    notInt <- which(!testres)
    stop(paste(
      "elements",
      paste(notInt, sep = ", "),
      "of vector are not integers!"
    ))
  }
  as.integer(x)
}

##' Shorthand for logit function
##'
##' @param x the function argument
##' @return the logit(x)
##'
##' @export
##' @keywords programming
logit <- function(x) {
  qlogis(x)
}

##' Shorthand for probit function
##'
##' @param x the function argument
##' @return the probit(x)
##'
##' @export
##' @keywords programming
probit <- function(x) {
  qnorm(x)
}

##' Open the example pdf for crmPack
##'
##' Calling this helper function should open the example.pdf document,
##' residing in the doc subfolder of the package installation directory.
##'
##' @return nothing
##' @export
##' @keywords documentation
##' @author Daniel Sabanes Bove \email{sabanesd@@roche.com}
crmPackExample <- function() {
  crmPath <- system.file(package = "crmPack")
  printVignette(list(PDF = "example.pdf", Dir = crmPath))
  ## instead of utils:::print.vignette
}

##' Open the browser with help pages for crmPack
##'
##' This convenience function opens your browser with the help pages for
##' crmPack.
##'
##' @return nothing
##' @export
##' @importFrom utils help
##' @keywords documentation
##' @author Daniel Sabanes Bove \email{sabanesd@@roche.com}
crmPackHelp <- function() {
  utils::help(package = "crmPack", help_type = "html")
}

#' Plot `gtable` Objects
#'
#' This is needed because `crmPack` uses [gridExtra::arrangeGrob()] to combine
#' `ggplot2` plots, and the resulting `gtable` object is not plotted otherwise
#' when implicitly printing it in the console, e.g.
#'
#' @method plot gtable
#' @param x (`gtable`)\cr object to plot.
#' @param ... additional parameters for [grid::grid.draw()].
#'
#' @export
plot.gtable <- function(x, ...) {
  grid::grid.draw(x, ...)
}

#' @method print gtable
#' @rdname plot.gtable
#' @export
print.gtable <- function(x, ...) {
  plot(x, ...)
}

##' Taken from utils package (print.vignette)
##'
##' @importFrom tools file_ext
##' @importFrom utils browseURL
##' @keywords internal
printVignette <- function(x, ...) {
  if (nzchar(out <- x$PDF)) {
    ext <- tools::file_ext(out)
    out <- file.path(x$Dir, "doc", out)
    if (tolower(ext) == "pdf") {
      pdfviewer <- getOption("pdfviewer")
      if (identical(pdfviewer, "false")) {
      } else if (.Platform$OS.type == "windows" && identical(
        pdfviewer,
        file.path(R.home("bin"), "open.exe")
      )) {
        shell.exec(out)
      } else {
        system2(pdfviewer, shQuote(out), wait = FALSE)
      }
    } else {
      browseURL(out)
    }
  } else {
    warning(gettextf("vignette %s has no PDF/HTML", sQuote(x$Topic)),
      call. = FALSE, domain = NA
    )
  }
  invisible(x)
}

##' Compute the density of Inverse gamma distribution
##' @param x vector of quantiles
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param log logical; if TRUE, probabilities p are given as log(p)
##' @param normalize logical; if TRUE, the output will be normalized
##'
##' @keywords internal
dinvGamma <- function(x,
                      a,
                      b,
                      log = FALSE,
                      normalize = TRUE) {
  ret <- -(a + 1) * log(x) - b / x
  if (normalize) {
    ret <- ret + a * log(b) - lgamma(a)
  }
  if (log) {
    return(ret)
  } else {
    return(exp(ret))
  }
}

##' Compute the distribution function of Inverse gamma distribution
##'
##' @param q vector of quantiles
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param lower.tail logical; if TRUE (default), probabilities are `P(X  > x)`,
##'   otherwise, `P(X <= x)`.
##' @param logical; FALSE (default) if TRUE, probabilities/densities p
##'   are returned as `log(p)`
##'
##' @keywords internal
pinvGamma <- function(q,
                      a,
                      b,
                      lower.tail = TRUE,
                      log.p = FALSE) {
  pgamma(
    q = 1 / q,
    shape = a,
    rate = b,
    lower.tail = !lower.tail,
    log.p = log.p
  )
}

##' Compute the quantile function of Inverse gamma distribution
##' @param p vector of probabilities
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##' @param lower.tail logical; if TRUE (default), probabilities are `P(X  > x)`,
##'   otherwise, `P(X <= x)`.
##' @param logical; FALSE (default) if TRUE, probabilities/densities p are
##'   returned as `log(p)`
##'
##' @keywords internal
qinvGamma <- function(p,
                      a,
                      b,
                      lower.tail = TRUE,
                      log.p = FALSE) {
  1 / qgamma(
    p = p,
    shape = a,
    rate = b,
    lower.tail = !lower.tail,
    log.p = log.p
  )
}
##' The random generation of the Inverse gamma distribution
##' @param n the number of observations
##' @param a the shape parameter of the inverse gamma distribution
##' @param b the scale parameter of the inverse gamma distribution
##'
##' @keywords internal
rinvGamma <- function(n,
                      a,
                      b) {
  1 / rgamma(n,
    shape = a,
    rate = b
  )
}

# nolint end

#' Combining S4 Class Validation Results
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that combines two outputs from calls to `result()`
#'   function which is placed in a slot of [Validate()] reference class.
#'
#' @param v1 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v2`.
#' @param v2 (`logical` or `character`)\cr an output from `result()` function from
#'   [Validate()] reference class, to be combined with `v1`.
#'
#' @export
#' @examples
#' h_validate_combine_results(TRUE, "some_message")
h_validate_combine_results <- function(v1, v2) {
  assert_true(test_true(v1) || test_character(v1, any.missing = FALSE, min.len = 1L))
  assert_true(test_true(v2) || test_character(v2, any.missing = FALSE, min.len = 1L))

  isTRUEv2 <- isTRUE(v2)
  if (isTRUE(v1)) {
    if (isTRUEv2) {
      TRUE
    } else {
      v2
    }
  } else {
    if (isTRUEv2) {
      v1
    } else {
      c(v1, v2)
    }
  }
}

#' Comparison with Numerical Tolerance and Without Name Comparison
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function ensures a default tolerance level equal to `1e-10`,
#' and ignores names and other attributes.
#' In contrast to [all.equal()], it always returns a logical type object.
#'
#' @param target (`numeric`)\cr target values.
#' @param current (`numeric`)\cr current values.
#' @param tolerance (`number`) relative differences smaller than this are not
#'   reported.
#' @return `TRUE` when `target` and `current` do not differ
#'   up to desired tolerance and without looking at names or other attributes,
#'   `FALSE` otherwise.
#'
#' @export
#'
h_all_equivalent <- function(target,
                             current,
                             tolerance = 1e-10) {
  assert_numeric(target)
  assert_numeric(current)
  assert_number(tolerance)

  tmp <- all.equal(
    target = target,
    current = current,
    tolerance = tolerance,
    check.names = FALSE,
    check.attributes = FALSE
  )
  isTRUE(tmp)
}

#' Preparing Data for Plotting
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `data.frame` object based on `Data` class
#' object. The resulting data frame is used by the plot function for `Data`
#' class objects.
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A [`data.frame`] object with values to plot.
#'
h_plot_data_df <- function(data, blind = FALSE, ...) {
  df <- data.frame(
    patient = seq_along(data@x),
    ID = paste(" ", data@ID),
    cohort = data@cohort,
    dose = data@x,
    toxicity = ifelse(data@y == 1, "Yes", "No"),
    ...
  )

  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (data@placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == data@doseGrid[1]] <- 0
  }

  df
}

#' Preparing Cohort Lines for Data Plot
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function prepares a `ggplot` geom with reference lines
#' separating different cohorts on the plot of `Data` class object.
#' Lines are either vertical or horizontal of green color and longdash type.
#'
#' @details The geom object is returned if and only if `placebo` is equal to
#'   `TRUE` and there are more than one unique values in `cohort`. Otherwise,
#'   this function returns `NULL` object.
#'
#' @param cohort (`integer`)\cr the cohort indices.
#' @param placebo (`flag`)\cr is placebo included in the doses?
#'   If it so, this function returns `NULL` object as in this case all doses
#'   in a given cohort are equal and there is no need to separate them.
#' @param vertical (`flag`)\cr should the line be vertical? Otherwise it is
#'   horizontal.
#'
h_plot_data_cohort_lines <- function(cohort,
                                     placebo,
                                     vertical = TRUE) {
  assert_integer(cohort)
  assert_flag(placebo)
  assert_flag(vertical)

  # If feasible, add vertical or horizontal green lines separating sub-sequent
  # cohorts.
  if (placebo && length(unique(cohort)) > 1) {
    intercept <- head(cumsum(table(cohort)), n = -1) + 0.5
    if (vertical) {
      geom_vline(xintercept = intercept, colour = "green", linetype = "longdash") # nolintr
    } else {
      geom_hline(yintercept = intercept, colour = "green", linetype = "longdash") # nolintr
    }
  } else {
    NULL
  }
}

#' Checking Formals of a Function
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given function `fun` has required or
#' allowed arguments. The argument check is based only on the names of the
#' arguments. No any further logic is verified here.
#'
#' @param fun (`function`)\cr a function name whose argument names will be
#'   checked.
#' @param mandatory (`character` or `NULL`)\cr the names of the arguments which
#'   must be present in `fun`. If `mandatory` is specified as `NULL` (default)
#'   this requirement is ignored.
#' @param allowed (`character` or `NULL`)\cr the names of the arguments which
#'   are allowed in `fun`. Names that do not belong to `allowed` are simply not
#'   allowed. The `allowed` parameter is independent from the `mandatory`, in a
#'   sense that if `mandatory` is specified as a `character` vector, it does not
#'   have to be repeated in `allowed`. If `allowed` is specified as `NULL`
#'   (default), then it means that there must be no any arguments in `fun`
#'   (except these ones which are specified in `mandatory`).
#'
#' @export
#'
h_check_fun_formals <- function(fun, mandatory = NULL, allowed = NULL) {
  assert_function(fun)
  assert_character(mandatory, null.ok = TRUE)
  assert_character(allowed, null.ok = TRUE)

  arg_names <- names(formals(fun))
  mandatory_check <- all(mandatory %in% arg_names)
  allowed_check <- all(arg_names %in% c(mandatory, allowed))

  mandatory_check && allowed_check
}

#' Getting the Slots from a S4 Object
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function extracts requested slots from the S4 class object.
#' It is a simple wrapper of [methods::slot()] function.
#'
#' @param object (`S4`)\cr an object from a formally defined S4 class.
#' @param names (`character`)\cr a vector with names of slots to be fetched.
#'   This function assumes that for every element in `names`, there exists a
#'   slot of the same name in the `object`.
#' @param simplify (`flag`)\cr should an output be simplified? This has an
#'   effect if and only if a single slot is about to be extracted, i.e.
#'   `names` is just a single string.
#'
#' @return `list` with the slots extracted from `object` according to `names`,
#'   or single slot if simplification is required and possible.
#'
#' @export
#'
h_slots <- function(object, names, simplify = FALSE) {
  assert_true(isS4(object))
  assert_character(names, any.missing = FALSE, null.ok = TRUE)
  assert_true(all(names %in% slotNames(object)))

  if (is.null(names) || length(names) == 0L) {
    return(list())
  }

  slots_list <- sapply(names, function(n) slot(object, n), simplify = FALSE, USE.NAMES = TRUE)

  if (simplify && length(names) == 1) {
    slots_list[[1]]
  } else {
    slots_list
  }
}

#' Conditional Formatting Using C-style Formats
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function conditionally formats a number with [formatC()]
#' function using `"E"` format and specific number of digits as given by the
#' user. A number is formatted if and only if its absolute value is less than
#' `0.001` or greater than `10000`. Otherwise, the number is not formatted.
#' Additionally, custom prefix or suffix can be appended to character string
#' with formatted number, so that the changes are marked.
#'
#' @note This function was primarily designed as a helper for
#'   [h_jags_write_model()] function.
#'
#' @param x (`number`)\cr a number to be formatted.
#' @param digits (`function`)\cr the desired number of significant digits.
#' @param prefix (`string`)\cr a prefix to be added in front of the formatted
#'   number.
#' @param suffix (`string`)\cr a suffix to be appended after the formatted
#'   number.
#'
#' @return Either formatted `x` as `string` or unchanged `x` if the
#'   formatting condition is not met.
#'
#' @export
#' @examples
#' h_format_number(50000)
#' h_format_number(50000, prefix = "P", suffix = "S")
h_format_number <- function(x,
                            digits = 5,
                            prefix = "",
                            suffix = "") {
  assert_number(x)
  assert_int(digits)
  assert_string(prefix)
  assert_string(suffix)

  if ((abs(x) < 1e-3) || (abs(x) > 1e+4)) {
    paste0(prefix, formatC(x, digits = digits, format = "E"), suffix)
  } else {
    x
  }
}

#' Recursively Apply a Function to a List
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function recursively iterates through a "list-like" object and it
#' checks whether an element is of a given class. If it so, then it replaces
#' that element by the result of an execution of a given function. Otherwise,
#' and if the element is of length greater than 1 (i.e. not a scalar), it
#' replaces that element by the result of `h_rapply()`, recursively called for
#' that element. In the remaining case, that is, the element is not of a given
#' class and is a scalar, then that element remains unchanged.
#'
#' @note This helper function is conceptually similar the same as [rapply()]
#'   function. However, it differs from [rapply()] in two major ways. First, the
#'   `h_rapply()` is not limited to objects of type `list` or `expression` only.
#'   It can be any "list-like" object of any type for which subsetting operator
#'   [`[[`][Extract] is defined. This can be, for example, an object of type
#'   `language`, often obtained from the [body()] function. The second
#'   difference is that the flexibility of [rapply()] on how the result is
#'   structured is not available with `h_rapply()` for the user. That is, with
#'   `h_rapply()` each element of `x`, which has a class included in `classes`,
#'   is replaced by the result of applying `fun` to the element. This behavior
#'   corresponds to [rapply()] when invoked with fixed `how = replace`.
#'   This function was primarily designed as a helper for [h_jags_write_model()]
#'   function.
#'
#' @param x (`any`)\cr "list-like" object for which subsetting operator
#'   [`[[`][Extract] is defined.
#' @param fun (`function`)\cr a function of one "principal" argument, passing
#'   further arguments via `...`.
#' @param classes (`character`)\cr class names.
#' @param ... further arguments passed to function `fun`.
#'
#' @return "list-like" object of similar structure as `x`.
#'
#' @export
#' @example examples/helpers-rapply.R
#'
h_rapply <- function(x, fun, classes, ...) {
  assert_function(fun)
  assert_character(classes, min.len = 1L)
  # To assert that `x` is subsettable.
  # If it works, fine, we don't see the result, otherwise it gives the error.
  force(x[[1]])

  for (i in seq_along(x)) {
    if (class(x[[i]]) %in% classes) {
      x[[i]] <- do.call(fun, c(list(x[[i]]), ...))
    } else if (length(x[[i]]) > 1L) {
      x[[i]] <- h_rapply(x[[i]], fun, classes, ...)
    }
  }
  x
}

#' Getting `NULL` for `NA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that replaces `NA` object by `NULL` object.
#'
#' @param x (`any`)\cr atomic object of length `1`. For the definition of
#'   "atomic", see [is.atomic()].
#'
#' @return `NULL` if `x` is `NA`, otherwise, `x`.
#'
#' @export
#' @examples
#' h_null_if_na(NA)
h_null_if_na <- function(x) {
  assert_atomic(x, len = 1L)

  if (is.na(x)) {
    NULL
  } else {
    x
  }
}

#' Getting the default value for an empty object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that sets a default value for an empty or missing object,
#' that is an object for which [length()] function returns `0L` or it has length 1
#' and [is.na()] returns `TRUE`.
#'
#' @param x (`any`) \cr an object to handle. It can be any object for which
#'   [length()] function is defined.
#' @param default (`any`) \cr a default value for `x` object.
#'
#' @export
#' @examples
#' h_default_if_empty(character(0), default = "default label")
#' h_default_if_empty("custom label", default = "default label")
#' h_default_if_empty(NA, default = "default label")
h_default_if_empty <- function(x, default) {
  if (length(x) == 0L || (length(x) == 1L && is.na(x))) {
    default
  } else {
    x
  }
}
#' Testing Matrix for Positive Definiteness
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This helper function checks whether a given numerical matrix `x` is a
#' positive-definite square matrix of a given size, without any missing
#' values. This function is used to test if a given matrix is a covariance
#' matrix, since every symmetric positive semi-definite matrix is a covariance
#' matrix.
#'
#' @details The positive definiteness test implemented in this function
#'   is based on the following characterization valid for real matrices:
#'   `A symmetric matrix is positive-definite if and only if all of its
#'   eigenvalues are positive.` In this function an eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @param x (`matrix`)\cr a matrix to be checked.
#' @param size (`integer`)\cr a size of the square matrix `x` to be checked
#'   against for.
#' @param tol (`number`)\cr a given tolerance number used to check whether
#'   an eigenvalue is positive or not. An eigenvalue is considered
#'   as positive if and only if it is greater than the `tol`.
#'
#' @return `TRUE` if a given matrix is a positive-definite, `FALSE` otherwise.
#'
#' @export
#'
h_is_positive_definite <- function(x, size = 2, tol = 1e-08) {
  assert_number(tol)

  is_matrix <- test_matrix(
    x,
    mode = "numeric", nrows = size, ncols = size, any.missing = FALSE
  )

  if (is_matrix) {
    is_symmetric <- all.equal(x, t(x), tolerance = tol)
    if (isTRUE(is_symmetric)) {
      ev <- eigen(x, only.values = TRUE)$values
      all(ev > tol)
    } else {
      FALSE
    }
  } else {
    FALSE
  }
}

#' Check that an argument is a named vector of type numeric
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether an object is a named numerical
#' vector.
#'
#' @note This function is based on [`checkmate::test_numeric()`] and
#'   [`checkmate::test_names()`] functions.
#'
#' @param x (`any`)\cr object to check.
#' @inheritParams checkmate::test_names
#' @inheritParams checkmate::test_numeric
#' @param ... further parameters passed to [`checkmate::test_numeric()`].
#'
#' @return `TRUE` if `x` is a named vector of type numeric, otherwise `FALSE`.
#'
#' @export
#' @examples
#' h_test_named_numeric(1:2, permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("a", "b"))
#' h_test_named_numeric(c(a = 1, b = 2), permutation.of = c("b", "a"))
h_test_named_numeric <- function(x,
                                 subset.of = NULL, # nolintr
                                 must.include = NULL, # nolintr
                                 permutation.of = NULL, # nolintr
                                 identical.to = NULL, # nolintr
                                 disjunct.from = NULL, # nolintr
                                 lower = 0 + .Machine$double.xmin,
                                 finite = TRUE,
                                 any.missing = FALSE, # nolintr
                                 len = 2,
                                 ...) {
  is_valid_num <- test_numeric(
    x,
    lower = lower,
    finite = finite,
    any.missing = any.missing,
    len = len,
    ...,
    names = "named"
  )
  are_names_valid <- test_names(
    names(x),
    subset.of = subset.of,
    must.include = must.include,
    permutation.of = permutation.of,
    identical.to = identical.to,
    disjunct.from = disjunct.from,
  )
  is_valid_num && are_names_valid
}

#' Check which elements are in a given range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that tests whether elements of a given vector or
#' matrix are within specified interval.
#'
#' @param x (`numeric`)\cr vector or matrix with elements to test.
#' @param range (`numeric`)\cr an interval, i.e. sorted two-elements vector.
#' @param bounds_closed (`logical`)\cr should bounds in the `range` be treated
#'   as closed? This can be a scalar or vector of length two. If it is a scalar,
#'   then its value applies to lower bound `range[1]` and upper bound
#'   `range[2]`. If this is a vector with two flags, the first flag corresponds
#'   to the lower bound only, and the second to the upper bound only.
#'
#' @return A logical vector or matrix of length equal to the length of `x`, that
#'   for every element of `x`, indicates whether a given element of `x` is in
#'   the `range`.
#'
#' @export
#' @examples
#' x <- 1:4
#' h_in_range(x, range = c(1, 3))
#' h_in_range(x, range = c(1, 3), bounds_closed = FALSE)
#' h_in_range(x, range = c(1, 3), bounds_closed = c(FALSE, TRUE))
#' mat <- matrix(c(2, 5, 3, 10, 4, 9, 1, 8, 7), nrow = 3)
#' h_in_range(mat, range = c(1, 5))
h_in_range <- function(x, range = c(0, 1), bounds_closed = TRUE) {
  assert_numeric(x)
  assert_numeric(range, any.missing = FALSE, len = 2, sorted = TRUE)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)

  above_lwr <- if (bounds_closed[1]) {
    x >= range[1]
  } else {
    x > range[1]
  }

  below_upr <- if (tail(bounds_closed, 1)) {
    x <= range[2]
  } else {
    x < range[2]
  }

  above_lwr & below_upr
}

#' Find Interval Numbers or Indices and Return Custom Number For 0.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple wrapper of [`findInterval()`] function that invokes
#' [`findInterval()`], takes its output and replaces all the
#' elements with \eqn{0} value to a custom number as specified in `replacement`
#' argument.
#'
#' @inheritDotParams base::findInterval
#' @param replacement (`number`)\cr a custom number to be used as a replacement
#'   for \eqn{0}. Default to `-Inf`.
#'
#' @export
#' @examples
#' h_find_interval(1, c(2, 4, 6))
#' h_find_interval(3, c(2, 4, 6))
#' h_find_interval(1, c(2, 4, 6), replacement = -1)
h_find_interval <- function(..., replacement = -Inf) {
  assert_number(replacement)

  x <- findInterval(...)
  ifelse(x == 0, yes = replacement, no = x)
}



#' Group Together Mono and Combo Data
#'
#' This is only used in the simulation method for `DesignGrouped` to combine
#' the separately generated data sets from mono and combo arms and to fit the
#' combined logistic regression model.
#' Hence the ID and cohort information is not relevant and will be
#' arbitrarily assigned to avoid problems with the [`DataGrouped`] validation.
#'
#' @param mono_data (`Data`)\cr mono data.
#' @param combo_data (`Data`)\cr combo data.
#'
#' @return A [`DataGrouped`] object containing both `mono_data` and `combo_data`,
#'   but with arbitrary ID and cohort slots.
#'
#' @keywords internal
h_group_data <- function(mono_data, combo_data) {
  assert_class(mono_data, "Data")
  assert_class(combo_data, "Data")

  df <- data.frame(
    x = c(mono_data@x, combo_data@x),
    y = c(mono_data@y, combo_data@y),
    group = rep(c("mono", "combo"), c(length(mono_data@x), length(combo_data@x)))
  )
  df <- df[order(df$x), ]

  DataGrouped(
    x = df$x,
    y = df$y,
    ID = seq_along(df$x),
    cohort = as.integer(factor(df$x)),
    doseGrid = sort(unique(c(mono_data@doseGrid, combo_data@doseGrid))),
    group = df$group
  )
}

#' @include helpers.R
NULL

#' Appending a Dummy Number for Selected Slots in Data
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
#' class object, if and only if the total number of observations (as indicated
#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
#'
#' @note The main motivation behind this function is related to the `JAGS`.
#'   If there is only one observation, the data is not passed correctly to
#'   `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
#'   Therefore it is necessary to add dummy values to the vectors in this case
#'   As we don't change the number of observations (`nObs`), this addition of
#'   zeros doesn't affect the results of `JAGS` computations.
#'
#' @param object (`GeneralData`)\cr object into which dummy values will be added.
#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
#'   number will be appended.
#' @param dummy (`number`)\cr a dummy number that will be appended to selected
#'   slots in `object`. Default to `0`.
#'
#' @return A [`GeneralData`] object with slots updated with dummy number.
#'
#' @export
#' @example examples/helpers-jags_add_dummy.R
#'
h_jags_add_dummy <- function(object, where, dummy = 0) {
  assert_class(object, "GeneralData")
  assert_character(where)
  assert_subset(where, slotNames(object))
  assert_number(dummy)

  if (object@nObs == 1L) {
    for (i in where) {
      # Add dummy value and preserve the class.
      slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
    }
  }
  object
}

#' Joining `JAGS` Models
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This helper function joins two JAGS models in the way that the body of the
#' second model is appended to the body of the first model (in this order).
#' After that, the first, body-extended model is returned. The arguments of
#' `model1`, `model2` model functions (if any) are not combined in any way.
#'
#' @note `model1` and `model2` functions must have a multi-expression
#'   body, i.e. braced expression(s). Environments or any attributes of the
#'   function bodies are not preserved in any way after joining.
#'
#' @param model1 (`function`)\cr the first model to join.
#' @param model2 (`function`)\cr the second model to join.
#'
#' @return joined models.
#'
#' @export
#'
h_jags_join_models <- function(model1, model2) {
  assert_function(model1)
  assert_function(model2)
  assert_class(body(model1), "{")
  assert_class(body(model2), "{")

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model2) <- h_covr_detrace(body(model2))
  }

  body2 <- as.list(body(model2))
  if (length(body2) >= 2) {
    body1 <- as.list(body(model1))
    body(model1) <- as.call(c(body1, body2[-1]))
  }
  model1
}


#' Setting Initial Values for `JAGS` Model Parameters
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `inits` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
#'   argument specifies initial values for model parameters.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#'
#' @return A `list` of starting values for parameters required to be initialized
#'   in the MCMC `JAGS `sampler.
#'
#' @export
#' @example examples/helpers-jags_get_model_inits.R
#'
h_jags_get_model_inits <- function(model, data) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")

  inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
  assert_list(inits)
  inits[sapply(inits, length) > 0L]
}

#' Getting Data for `JAGS`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that prepares an object for `data` argument of
#'   [rjags::jags.model()], which is invoked by [mcmc()] method.
#'
#' @param model (`GeneralModel`)\cr an input model.
#' @param data (`GeneralData`)\cr an input data.
#' @param from_prior (`flag`)\cr sample from the prior only? In this case
#'   data will not be appended to the output, i.e. only the variables required
#'   by the `model@priormodel` model will be returned in data.
#'
#' @export
#' @example examples/helpers-jags_get_data.R
#'
h_jags_get_data <- function(model, data, from_prior) {
  assert_class(model, "GeneralModel")
  assert_class(data, "GeneralData")
  assert_flag(from_prior)

  # 1) Extract variables from `data` as required by `modelspecs`.
  ms_args_names <- formalArgs(model@modelspecs)
  ms_args <- if ("from_prior" %in% ms_args_names) {
    c(h_slots(data, setdiff(ms_args_names, "from_prior")), list(from_prior = from_prior))
  } else {
    h_slots(data, ms_args_names)
  }
  modelspecs <- do.call(model@modelspecs, ms_args)
  assert_list(modelspecs)

  # 2) Extract variables from `data` as required by `datanames`.
  datanames <- if (from_prior) {
    model@datanames_prior
  } else {
    union(model@datanames, model@datanames_prior)
  }

  # Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
  # scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
  add_where <- setdiff(datanames, c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax"))
  data <- h_jags_add_dummy(data, where = add_where)

  data_model <- h_slots(data, datanames)
  c(data_model, modelspecs)
}

#' Writing JAGS Model to a File
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function converts a R function with JAGS model into a text and then
#' writes it into a given file. During the "model into text" conversion, the
#' format of numbers of which absolute value is less than `0.001` or greater
#' than `10000` is changed. These numbers will be converted into scientific
#' format with specified number of significant digits using [formatC()]
#' function.
#'
#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
#'   which is illegal in R. To overcome this incompatibility, use dummy operator
#'   `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
#'   code. This dummy operator `\%_\%` will be removed just before saving the
#'   JAGS code into a file.
#'   Due to technical issues related to conversion of numbers to scientific
#'   format, it is required that the body of a model function does not contain
#'   `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
#'
#' @param model (`function`)\cr function containing the JAGS model.
#' @param file (`string` or `NULL`)\cr the name of the file (including the
#'   optional path) where the model will be saved. If `NULL`, the file will be
#'   created in a `R_crmPack` folder placed under temporary directory indicated
#'   by [tempdir()] function.
#' @param digits (`count`)\cr a desired number of significant digits for
#'   for numbers used in JAGS input, see [formatC()].
#' @return The name of the file where the model was saved.
#'
#' @export
#' @example examples/helpers-jags_write_model.R
#'
h_jags_write_model <- function(model, file = NULL, digits = 5) {
  assert_function(model)
  assert_count(digits)

  # This workaround is needed to avoid bugs related to covr-injected code.
  if (h_covr_active()) {
    body(model) <- h_covr_detrace(body(model))
  }

  if (!is.null(file)) {
    assert_path_for_output(file)
  } else {
    dir <- file.path(tempdir(), "R_crmPack")
    # Don't warn, as the temp dir often exists (which is OK).
    dir.create(dir, showWarnings = FALSE)
    file <- tempfile(
      pattern = "jags_model_fun",
      tmpdir = dir,
      fileext = ".txt"
    )
  }

  # Replace scientific notation.
  model_sci_replaced <- h_rapply(
    x = body(model),
    fun = h_format_number,
    classes = c("integer", "numeric"),
    digits = digits,
    prefix = "TEMP_NUM_PREF_",
    suffix = "_TEMP_NUM_SUF"
  )
  # Transform `model` body into character vector.
  model_text <- deparse(model_sci_replaced, control = NULL)
  model_text <- gsub("\"TEMP_NUM_PREF_|_TEMP_NUM_SUF\"", "", model_text)
  model_text <- gsub("%_% ", "", model_text)
  model_text <- c("model", model_text)

  log_trace("Writting JAGS model function into: %s", file)
  writeLines(model_text, con = file)
  file
}

#' Extracting Samples from `JAGS` `mcarray` Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A simple helper function that extracts a sample from
#'   [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
#'   object is used by the [rjags::jags.samples()] function to represent MCMC
#'   output from a `JAGS` model.
#'
#' @param x an [`rjags::mcarray.object`] object.
#'
#' @export
#'
h_jags_extract_samples <- function(x) {
  assert_class(x, "mcarray")

  x <- x[, , 1L]
  # In case that there are multiple parameters in a node.
  if (is.matrix(x)) {
    x <- t(x)
  }
  x
}

# Design ----

#' Internal Helper Functions for Validation of [`RuleDesign`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesign`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesign`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesign`] object
#'   contains valid `startingDose`.
v_rule_design <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@startingDose, finite = TRUE),
    "startingDose must be a number"
  )
  v$check(
    test_subset(object@startingDose, choices = object@data@doseGrid, empty.ok = FALSE),
    "startingDose must be included in data@doseGrid"
  )
  v$result()
}

#' Internal Helper Functions for Validation of [`RuleDesignOrdinal`] Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an input
#' [`RuleDesignOrdinal`] or inherited classes and therefore not exported.
#'
#' @name v_design
#' @param object (`RuleDesignOrdinal`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_design validates that the [`RuleDesignOrdinal`] object
#'   contains valid `starting_dose`.
v_rule_design_ordinal <- function(object) {
  v <- Validate()
  v$check(
    test_number(object@starting_dose, finite = TRUE),
    "starting_dose must be a number"
  )
  v$check(
    test_subset(object@starting_dose, choices = object@data@doseGrid, empty.ok = FALSE),
    "starting_dose must be included in data@doseGrid"
  )
  v$result()
}


#' @describeIn v_design validates that the [`DesignGrouped`] object
#'   contains valid flags.
v_design_grouped <- function(object) {
  v <- Validate()
  v$check(
    test_flag(object@first_cohort_mono_only),
    "first_cohort_mono_only must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_all must be a flag"
  )
  v$check(
    test_flag(object@same_dose_for_all),
    "same_dose_for_start must be a flag"
  )
  v$result()
}

# Generics ----

#' Obtain a Text Representation of the Reference Dose
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`GeneralModel`)\cr the model object that will be printed
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_ref_dose <- function(x, ...) {
  UseMethod("h_knit_print_render_ref_dose")
}

#' Render a Model Function in a `knit_print` Method
#'
#' This is a helper method used `knit_print` for `crmPack` classes.
#'
#' @param x (`GeneralModel`)\cr the model object that will be printed
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_model <- function(x, ...) {
  UseMethod("h_knit_print_render_model")
}

#' Obtain a Text Representation of a Biomarker Model
#'
#' This is a helper method used `knit_print` for `DualEndpoint` classes.
#'
#' @param x (`DualEndpoint`)\cr the model object containing the biomarker model
#' @param use_values (`flag`)\cr print the values associated with hyperparameters,
#' or the symbols used to define the hyper-parameters.  That is, for example, mu or 1.
#' @param ... Not used at present
#' @return A character string containing a LaTeX rendition of the model.
#' @noRd
h_knit_print_render_biomarker_model <- function(x, use_values = TRUE, ...) {
  UseMethod("h_knit_print_render_biomarker_model")
}

# Methods ----

# DualEndpoint ----

#' @description `r lifecycle::badge("experimental")`
#' @param biomarker_name (`character`)\cr A description of the biomarker
#' @rdname knit_print
#' @export
#' @method knit_print DualEndpoint
knit_print.DualEndpoint <- function(
    x,
    ...,
    asis = TRUE,
    use_values = TRUE,
    fmt = "%5.2f",
    units = NA,
    biomarker_name = "a PD biomarker") {
  assert_flag(asis)
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  assert_character(biomarker_name, len = 1, any.missing = FALSE)
  # Initialise
  if (is.na(units)) {
    units <- ""
  } else {
    units <- paste0(" ", units)
  }
  # Execute
  toxModel <- ProbitLogNormal(
    cov = x@betaZ_params@cov,
    mean = x@betaZ_params@mean,
    ref_dose = x@ref_dose
  )
  rv <- paste0(
    "The relationships between dose and toxicity and between dose and ",
    biomarker_name,
    " will be modelled simultaneously.\n\n",
    knit_print(toxModel, asis = asis, use_values = use_values, fmt = fmt, units = units),
    "\n\n",
    "The ",
    biomarker_name,
    " response `w` at dose `d` is modelled as ",
    "$$ w(d) \\sim N(f(d), \\sigma_w^2) $$ \n\nwhere ",
    h_knit_print_render_biomarker_model(x, use_values = use_values)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpoint <- function(x, ..., use_values = TRUE) {
  "f(d) is a function of dose that is defined elsewhere."
}

# DualEndpointBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointBeta <- function(x, ...) {
  paste0(
    "f(d) is a parametric rescaled beta density function such that\n\n",
    "$$ f(d) = ",
    "E_0 + (E_{max} - E_0) \\times Beta(\\delta_1, \\delta_2) \\times ",
    "\\left(\\frac{d}{d_{max}}\\right)^{\\delta_1}  \\times \\left(1 - ",
    "\\frac{d}{d_{max}}\\right)^{\\delta_2} $$\n\n",
    "where d~max~ is the maximum dose in the dose grid, &delta;~1~ and ",
    "&delta;~2~ are the parameters of the Beta function and ",
    "E~0~ and E~max~ are, respectively, the minimum and maximum levels of the ",
    "biomarker.  The mode can be written as \n\n",
    "$$ \\text{mode} = \\frac{\\delta_1}{\\delta_1 + \\delta_2} $$\n\n",
    " and this is the parameterisation used to define the model.\n\n",
    "In this case, \n\n",
    ifelse(
      length(x@E0) == 1,
      paste0("$$ E_0 = ", x@E0, " $$\n\n)"),
      paste0("$$ E_0  \\sim U(", x@E0[1], ", ", x@E0[2], ") $$\n\n")
    ),
    ifelse(
      length(x@Emax) == 1,
      paste0("$$ E_{max} = ", x@Emax, " $$\n\n)"),
      paste0("$$ E_{max}  \\sim U(", x@Emax[1], ", ", x@Emax[2], ") $$\n\n")
    ),
    ifelse(
      length(x@delta1) == 1,
      paste0("$$ \\delta_1 = ", x@delta1, " $$\n\n)"),
      paste0("$$ \\delta_1  \\sim U(", x@delta1[1], ", ", x@delta1[2], ") $$\n\n")
    ),
    ifelse(
      length(x@mode) == 1,
      paste0("$$ \\text{mode} = ", x@mode, " $$\n\n)"),
      paste0("$$ \\text{mode}  \\sim U(", x@mode[1], ", ", x@mode[2], ") $$\n\n")
    ),
    " and \n\n",
    ifelse(
      length(x@ref_dose_beta) == 1,
      paste0("$$ d_{max} = ", x@ref_dose_beta, " $$\n\n"),
      paste0("$$ d_{max}  \\sim U(", x@ref_dose_beta[1], ", ", x@ref_dose_beta[2], ") $$\n\n")
    )
  )
}

# DualEndpointEmax ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointEmax <- function(x, ...) {
  paste0(
    "f(d) is a parametric Emax density function such that\n\n",
    "$$ f(d) = ",
    "E_0 + \\frac{(E_{max} - E_0) \\times \\frac{d}{d^*}}{\\text{ED}_{50} + \\frac{d}{d^*}} $$\n\n",
    "where d* is the reference dose, E~0~ and E~max~ are, respectively, the ",
    "minimum and maximum levels of the biomarker and ED~50~ is the dose achieving ",
    "half the maximum effect, 0.5 &times; E~max~.\n\n",
    "In this case, \n\n",
    ifelse(
      length(x@E0) == 1,
      paste0("$$ E_0 = ", x@E0, " $$\n\n)"),
      paste0("$$ E_0  \\sim U(", x@E0[1], ", ", x@E0[2], ") $$\n\n")
    ),
    ifelse(
      length(x@Emax) == 1,
      paste0("$$ E_{max} = ", x@Emax, " $$\n\n)"),
      paste0("$$ E_{max}  \\sim U(", x@Emax[1], ", ", x@Emax[2], ") $$\n\n")
    ),
    ifelse(
      length(x@ED50) == 1,
      paste0("$$ \\text{ED}_{50} = ", x@ED50, " $$\n\n)"),
      paste0("$$ \\text{ED}_{50}  \\sim U(", x@ED50[1], ", ", x@ED50[2], ") $$\n\n")
    ),
    " and \n\n",
    ifelse(
      length(x@ref_dose_emax) == 1,
      paste0("$$ d^* = ", x@ref_dose_emax, " $$\n\n"),
      paste0("$$ d^* \\sim U(", x@ref_dose_emax[1], ", ", x@ref_dose_emax[2], ") $$\n\n")
    )
  )
}

# DualEndpointRW ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_biomarker_model.DualEndpointRW <- function(x, ..., use_values = TRUE) {
  paste0(
    "f(d) is a ",
    ifelse(x@rw1, "first", "second"),
    " order random walk such that\n\n",
    "$$ f(d) = ",
    "\\beta_{W_i} - \\beta_{W_{i - ",
    ifelse(x@rw1, "1", "2"),
    "}}",
    "\\sim N(0, ",
    ifelse(x@rw1, "", "2 \\times "),
    ifelse(
      use_values & length(x@sigma2betaW) == 1,
      x@sigma2betaW,
      "\\sigma_{\\beta_W}^2"
    ),
    " \\times (d_i - d_{i - ",
    ifelse(x@rw1, "1", "2"),
    "})",
    ")",
    " $$\n\n",
    ifelse(
      length(x@sigma2betaW) == 1,
      ifelse(
        use_values,
        "",
        paste0(" and $\\sigma_{\\beta_W}^2$ is fixed at ", x@sigma2betaW)
      ),
      paste0(
        " and the prior for $\\sigma_{\\beta_W}^2$ is an inverse-gamma distribution with parameters ",
        "a = ",
        x@sigma2betaW["a"],
        " and b = ",
        x@sigma2betaW["b"]
      )
    )
  )
}

# ModelParamsNormal ----

#' Render a Normal Prior
#'
#' @param x (`ModelParamsNormal`)\cr the object to be rendered
#' @param use_values (`flag`)\cr print the values associated with hyperparameters,
#' or the symbols used to define the hyper-parameters.  That is, for example, mu or 1.
#' @param fmt (`character`)\cr the `sprintf` format string used to render
#' numerical values.  Ignored if `use_values` is `FALSE`.
#' @param params (`character`)\cr The names of the model parameters.  See Usage
#' Notes below.
#' @param preamble (`character`)\cr The text used to introduce the LaTeX representation
#' of the model
#' @param asis (`flag`)\cr wrap the return value in a call to `knitr::asis_output`?
#' @param theta (`character`)\cr the LaTeX representation of the theta vector
#' @param ... Not used at present
#' @section Usage Notes:
#' `params` must be a character vector of length equal to that of `x@mean` (and
#' `x@cov`).  Its values represent the parameters of the model as entries in the
#' vector `theta`, on the left-hand side of "~" in the definition of the prior.
#' If named, names should be valid LaTeX, escaped as usual for R character variables.
#' For example, `"\\alpha"` or `"\\beta_0"`.  If unnamed, names are constructed by
#' pre-pending an escaped backslash to each value provided.
#' @return A character string containing a LaTeX rendition of the object.
#' @description `r lifecycle::badge("experimental")`
#' @export
#' @rdname knit_print
#' @method knit_print ModelParamsNormal
knit_print.ModelParamsNormal <- function(
    x,
    use_values = TRUE,
    fmt = "%5.2f",
    params = c("alpha", "beta"),
    preamble = "The prior for &theta; is given by\\n",
    asis = TRUE,
    theta = "\\theta",
    ...) {
  # Validate
  assert_class(x, "ModelParamsNormal")
  assert_format(fmt)
  assert_character(preamble, len = 1)
  assert_true(length(x@mean) == length(params))
  assert_flag(asis)
  # Initialise
  n <- length(params)
  if (is.null(names(params))) {
    names(params) <- paste0("\\", params)
  }
  # Execute
  # Construct LaTeX representation of mean vector
  mu <- sapply(
    1:n,
    function(i) {
      ifelse(
        use_values,
        sprintf(fmt, x@mean[i]),
        paste0("\\mu_{\\", params[i], "}")
      )
    }
  )
  # Construct LaTeX representation of covariance matrix
  cov <- sapply(
    1:n,
    function(i) {
      sapply(
        1:n,
        function(j) {
          ifelse(
            use_values,
            sprintf(fmt, x@cov[i, j]),
            ifelse(
              i == j,
              paste0("\\sigma_{\\", params[i], "}^2"),
              paste0("\\rho\\sigma_{\\", params[i], "}\\sigma_{\\", params[j], "}")
            )
          )
        }
      )
    }
  )
  # Construct LaTeX representation of prior
  rv <- paste0(
    preamble,
    "$$ \\boldsymbol",
    theta,
    " = \\begin{bmatrix}",
    paste0(names(params), collapse = " \\\\ "),
    "\\end{bmatrix}",
    "\\sim N \\left(\\begin{bmatrix}",
    paste0(mu, collapse = " \\\\ "),
    "\\end{bmatrix} , ",
    "\\begin{bmatrix} ",
    paste0(
      sapply(
        1:n,
        function(j) {
          stringr::str_trim(paste0(cov[, j], collapse = " & "))
        }
      ),
      collapse = " \\\\ "
    ),
    "\\end{bmatrix}",
    " \\right)",
    " $$"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# GeneralModel ----

#' @export
#' @rdname knit_print
#' @method knit_print GeneralModel
knit_print.GeneralModel <- function(
    x,
    ...,
    params = c("alpha", "beta"),
    asis = TRUE,
    use_values = TRUE,
    fmt = "%5.2f",
    units = NA) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt),
    knit_print(x@params, ..., asis = asis, use_values = use_values, fmt = fmt, params = params),
    "\\n\\n",
    h_knit_print_render_ref_dose(x, use_values = use_values, fmt = fmt, unit = unit)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @keywords internal
h_knit_print_render_ref_dose.GeneralModel <- function(x, ..., use_values = TRUE, fmt = "%5.2f", units = NA) {
  # Validate
  assert_character(units, len = 1)
  # Initialise
  if (is.na(units)) {
    units <- ""
  } else {
    units <- paste0(" ", units)
  }
  # Execute
  ref_dose <- ifelse(
    use_values,
    paste0(
      " The reference dose will be ",
      stringr::str_trim(sprintf(fmt, x@ref_dose)),
      units,
      ".\n\n"
    ),
    ""
  )
  ref_dose
}

# LogisticKadane ----

#' @keywords internal
h_knit_print_render_ref_dose.LogisticKadane <- function(x, ...) {
  # The LogisticKadane class has no reference dose slot
  ""
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticKadane
knit_print.LogisticKadane <- function(x, ..., asis = TRUE, use_values = TRUE, fmt = "%5.2f", units = NA) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  if (is.na(units)) {
    units <- ""
  } else {
    units <- paste0(" ", units)
  }
  # Execute
  rv <- paste0(
    "A logistic model using the parameterisation of Kadane (1980)  will ",
    "describe the relationship between dose and toxicity.\n\n ",
    ifelse(
      use_values,
      paste0(
        "Let the minimum (x~min~) and maximum (x~max~) doses be ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmin)), units),
        " and ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmax)), units),
        ".\n\n"
      ),
      "Let x~min~ and x~max~ denote, respectively, the minimum and maximum doses.\n\n  "
    ),
    "Further, let &theta; denote the target toxicity rate and &rho;~0~ = p(DLT | D = x~min~).\n\n",
    "Let &gamma; be the dose with target toxicity rate &theta;, so that p(DLT | D = &gamma;) = &theta;",
    ifelse(
      use_values,
      paste0(" = ", x@theta, ".\n\n"),
      ".\n\n"
    ),
    "Using this parameterisation, standard logistic regression model has slope ",
    "$$ \\frac{\\gamma \\text{logit}(\\rho_0) - x_{min} \\text{logit}(\\theta)}{\\gamma - x_{min}} $$",
    " and intercept ",
    "$$ \\frac{\\text{logit}(\\theta) - logit(\\rho_0)}{\\gamma - x_{min}} $$",
    " The priors for &Gamma; and &Rho;~0~ are ",
    ifelse(
      use_values,
      paste0("$$ \\Gamma \\sim U(", sprintf(fmt, x@xmin), ", ", sprintf(fmt, x@xmax), ") $$"),
      "$$ \\Gamma \\sim U(x_{min}, x_{max}) $$"
    ),
    " and, independently, ",
    ifelse(
      use_values,
      paste0("$$ \\mathrm{P}_0 \\sim U(0, ", x@theta, ") $$"),
      "$$ \\mathrm{P}_0 \\sim U(0, \\theta) $$"
    ),
    "\n\n Note that x~min~ and x~max~ need not be equal to the smallest and ",
    "largest values in the `doseGrid` slot of the corresponding `Data` object.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticKadaneBetaGamma ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticKadaneBetaGamma
knit_print.LogisticKadaneBetaGamma <- function(x, ..., asis = TRUE, use_values = TRUE, fmt = "%5.2f", units = NA) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Initialise
  if (is.na(units)) {
    units <- ""
  } else {
    units <- paste0(" ", units)
  }
  # Execute
  rv <- paste0(
    "A logistic model using the parameterisation of Kadane (1980)  will ",
    "describe the relationship between dose and toxicity, using a Beta ",
    "distribution as the prior for &rho;~0~ and a Gamma distribution as the prior ",
    "for &gamma;.\n\n ",
    ifelse(
      use_values,
      paste0(
        "Let the minimum (x~min~) and maximum (x~max~) doses be ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmin)), units),
        " and ",
        paste0(stringr::str_trim(sprintf(fmt, x@xmax)), units),
        ".\n\n"
      ),
      "Let x~min~ and x~max~ denote, respectively, the minimum and maximum doses.\n\n  "
    ),
    "Further, let &theta; denote the target toxicity rate and &rho;~0~ = p(DLT | D = x~min~).\n\n",
    "Let &gamma; be the dose with target toxicity rate &theta;, so that p(DLT | D = &gamma;) = &theta;",
    ifelse(
      use_values,
      paste0(" = ", x@theta, ".\n\n"),
      ".\n\n"
    ),
    "Using this parameterisation, standard logistic regression model has slope ",
    "$$ \\frac{\\gamma \\text{logit}(\\rho_0) - x_{min} \\text{logit}(\\theta)}{\\gamma - x_{min}} $$",
    " and intercept ",
    "$$ \\frac{\\text{logit}(\\theta) - logit(\\rho_0)}{\\gamma - x_{min}} $$",
    " The priors for &Gamma; and &Rho;~0~ are ",
    ifelse(
      use_values,
      paste0("$$ \\Gamma \\sim U(", sprintf(fmt, x@shape), ", ", sprintf(fmt, x@rate), ") $$"),
      "$$ \\Gamma \\sim Gamma( \\text{shape}, \\text{rate}) $$"
    ),
    " and, independently, ",
    ifelse(
      use_values,
      paste0("$$ \\mathrm{P}_0 \\sim Beta(", x@alpha, ", ", x@beta, ") $$"),
      "$$ \\mathrm{P}_0 \\sim Beta(\\alpha, \\beta) $$"
    ),
    "\n\n Note that x~min~ and x~max~ need not be equal to the smallest and ",
    "largest values in the `doseGrid` slot of the corresponding `Data` object.\n\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormal <- function(x, ...) {
  z <- "e^{\\alpha + \\beta \\cdot log(d/d_{ref})}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and toxicity: ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{", z, "}{1 + ", z, "} $$\\n ",
    "where d~ref~ denotes a reference dose.\n\n"
  )
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormal
knit_print.LogisticLogNormal <- function(
    x,
    ...,
    use_values = TRUE,
    fmt = "%5.2f",
    params = c(
      "\\alpha" = "alpha",
      "log(\\beta)" = "beta"
    ),
    preamble = "The prior for &theta; is given by\\n",
    asis = TRUE) {
  assert_flag(asis)
  # Can't use NextMethod() on a S4 class
  knit_print.GeneralModel(
    x,
    ...,
    use_values = use_values,
    fmt = fmt,
    params = params,
    preamble = preamble,
    asis = asis
  )
}

# LogisticLogNormalMixture ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalMixture <- function(x, use_values = TRUE, ...) {
  z1 <- "e^{\\alpha_1 + \\beta_1 \\cdot log(d/d^*)}"
  z2 <- "e^{\\alpha_2 + \\beta_2 \\cdot log(d/d^*)}"
  pi_text <- ifelse(
    use_values,
    x@share_weight,
    "\\pi"
  )
  paste0(
    "A mixture of two logistic log normal models will describe the relationship between dose and toxicity: ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = ",
    pi_text,
    " \\times \\frac{", z1, "}{1 + ", z1, "} + (1 - ",
    pi_text,
    ") \\times \\frac{", z2, "}{1 + ", z2, "} $$",
    ifelse(
      use_values,
      "where d* denotes a reference dose.\n\n",
      "where d* denotes a reference dose and &pi; is a fixed value between 0 and 1.\n\n"
    )
  )
}

#' @export
#' @rdname knit_print
#' @method knit_print LogisticLogNormalMixture
knit_print.LogisticLogNormalMixture <- function(x, ..., asis = TRUE, use_values = TRUE, fmt = "%5.2f", units = NA) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt),
    knit_print(
      x@params,
      ...,
      asis = asis,
      use_values = use_values,
      fmt = fmt,
      preamble = "The priors for both &theta;~1~ and &theta;~2~ are given by\\n"
    ),
    "\\n\\n",
    h_knit_print_render_ref_dose(x, use_values = use_values, fmt = fmt, unit = unit)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormalSub ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalSub <- function(x, ...) {
  z <- "e^{\\alpha + \\beta \\cdot (d \\, - \\, d^*)}"
  paste0(
    "A logistic log normal model with subtractive dose normalisation will ",
    "describe the relationship between dose and toxicity: \n\n",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{", z, "}{1 + ", z, "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalSub
knit_print.LogisticLogNormalSub <- function(
    x,
    ...,
    use_values = TRUE,
    fmt = "%5.2f",
    params = c(
      "\\alpha" = "alpha",
      "log(\\beta)" = "beta"
    ),
    preamble = "The prior for &theta; is given by\\n",
    asis = TRUE) {
  NextMethod(params = params)
}

# LogisticNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormal <- function(x, ...) {
  z <- "e^{\\alpha + \\beta \\cdot d/d^*}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and toxicity: ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{", z, "}{1 + ", z, "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ProbitLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ProbitLogNormal <- function(x, ...) {
  paste0(
    "A probit log normal model will describe the relationship between dose and toxicity: ",
    "$$ \\Phi^{-1}(Tox | d) = f(X = 1 | \\theta, d) = \\alpha + \\beta \\cdot log(d/d^*) $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ProbitLogNormalRel ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ProbitLogNormalRel <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  paste0(
    "A probit log normal model will describe the relationship between dose and toxicity: ",
    "$$ \\Phi^{-1}(Tox | d) = f(X = 1 | \\theta, d) = \\alpha + \\beta \\cdot d/d^* $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# LogisticNormalMixture ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormalMixture <- function(x, ...) {
  z <- "e^{\\alpha + \\beta \\cdot log(d/d^*)}"
  paste0(
    "A mixture of two logistic log normal models will describe the relationship between dose and toxicity: ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{", z, "}{1 + ", z, "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

#' @export
#' @rdname knit_print
#' @method knit_print LogisticNormalMixture
knit_print.LogisticNormalMixture <- function(x, ..., asis = TRUE, use_values = TRUE, fmt = "%5.2f", units = NA) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt),
    "The prior for &theta; is given by\\n",
    "$$ \\theta = \\begin{bmatrix} \\alpha \\\\ log(\\beta) \\end{bmatrix}",
    " \\sim ",
    "w \\cdot ",
    knit_print(
      x@comp1,
      params = c("\\alpha" = "alpha", "\\beta" = "beta")
    ),
    " + (1 - w) \\cdot ",
    knit_print(
      x@comp2,
      params = c("\\alpha" = "alpha", "\\beta" = "beta")
    ),
    " $$\\n\\n",
    " and the prior for w is given by \n\n",
    " $$ w \\sim Beta(", x@weightpar[1], ", ", x@weightpar[2], ") $$\\n\\n",
    h_knit_print_render_ref_dose(x, units = units, fmt = fmt, use_values = use_values, ...)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticNormalFixedMixture ----

#' @export
#' @rdname knit_print
#' @method knit_print LogisticNormalFixedMixture
knit_print.LogisticNormalFixedMixture <- function(x, ..., asis = TRUE, use_values = TRUE, fmt = "%5.2f", units = NA) {
  # Validate
  assert_flag(asis)
  assert_flag(use_values)
  assert_format(fmt)
  # Execute
  beta <- ifelse(x@log_normal, "log(\\beta)", "\\beta")
  rv <- paste0(
    h_knit_print_render_model(x, use_values = use_values, fmt = fmt),
    " The prior for &theta; is given by\\n\\n",
    "$$ \\theta = \\begin{bmatrix} \\alpha \\\\ ", beta, " \\end{bmatrix}",
    " \\sim \\sum_{i=1}^{", length(x@components), "}",
    "w_i \\cdot N \\left( \\mathbf{\\mu}_i ,  \\mathbf{\\Sigma}_i \\right)",
    " $$ \\n\\n",
    " with \\n\\n",
    "$$ \\sum_{i=1}^{", length(x@components), "} w_i = 1 $$ \\n\\n",
    " The individual components of the mixture are "
  )
  if (x@log_normal) {
    params <- c("\\alpha" = "alpha", "log(\\beta)" = "beta")
  } else {
    params <- c("\\alpha" = "alpha", "\\beta" = "beta")
  }
  for (i in seq_along(x@components)) {
    comp <- x@components[[i]]
    rv <- paste0(
      rv,
      knit_print(
        comp,
        params = params,
        preamble = " ",
        use_values = use_values,
        fmt = fmt,
        theta = paste0("\\theta_", i)
      ),
      " with weight ", x@weights[i],
      ifelse(
        i < length(x@components),
        " and",
        " "
      )
    )
  }
  rv <- paste0(
    rv,
    " \\n\\n ",
    h_knit_print_render_ref_dose(x, units = units, fmt = fmt, use_values = use_values, ...)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticNormalFixedMixture <- function(x, ...) {
  z <- "e^{\\alpha + \\beta \\cdot log(d/d^*)}"
  paste0(
    "A mixture of ",
    length(x@components),
    " logistic log normal models with fixed weights will describe the relationship ",
    "between dose and toxicity: ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{", z, "}{1 + ", z, "} $$\\n ",
    "where d* denotes a reference dose.\n\n"
  )
}

# ModelLogNormal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.ModelLogNormal <- function(x, ...) {
  "The model used to characterise the dose toxicity relationship is defined in  subclasses.\n\n"
}

# OneParLogNormalPrior ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print OneParLogNormalPrior
knit_print.OneParLogNormalPrior <- function(x, ..., asis = TRUE, use_values = TRUE, fmt = "%5.2f") {
  assert_flag(asis)

  s2text <- ifelse(
    use_values,
    stringr::str_trim(sprintf(fmt, x@sigma2)),
    "\\sigma^2"
  )
  rv <- paste0(
    "The relationship between dose and toxicity will be modelled using a version ",
    "of the one parameter CRM of O'Quigley et al (1990) with an exponential prior on the ",
    "power parameter for the skeleton prior probabilities, with",
    ifelse(
      use_values,
      paste0("$$ \\Theta \\sim Exp(", s2text, ") $$"),
      "$$ \\Theta \\sim Exp(\\lambda) $$"
    ),
    "and skeleton probabilities as in the table below."
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# OneParExpPrior ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print OneParExpPrior
knit_print.OneParExpPrior <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- "TODO"
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# LogisticLogNormalGrouped ----

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalGrouped
knit_print.LogisticLogNormalGrouped <- function(
    x,
    ...,
    use_values = TRUE,
    fmt = "%5.2f",
    params = c(
      "\\alpha" = "alpha",
      "\\beta" = "beta",
      "log(\\delta_0)" = "delta_0",
      "log(\\delta_1)" = "delta_1"
    ),
    preamble = "The prior for &theta; is given by\\n",
    asis = TRUE) {
  NextMethod(params = params)
}

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalGrouped <- function(x, ...) {
  z <- "e^{(\\alpha + I_c \\times \\delta_0) + (\\beta  + I_c \\times \\delta_1) \\cdot log(d/d^*)}"
  paste0(
    "A logistic log normal model will describe the relationship between dose and toxicity: ",
    "$$ p(Tox | d) = f(X = 1 | \\theta, d) = \\frac{", z, "}{1 + ", z, "} $$\\n ",
    "where d* denotes a reference dose and I~c~ is a binary indicator which ",
    "is 1 for the combo arm and 0 for the mono arm.\n\n"
  )
}

# LogisticLogNormalOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @noRd
h_knit_print_render_model.LogisticLogNormalOrdinal <- function(x, ...) {
  z <- "e^{\\alpha_k + \\beta \\cdot log(d/d^*)}"
  paste0(
    "Let p~k~(d) be the probability that the response of a patient treated at ",
    "dose d is in category k *_or higher_*, k=0, ..., K; d=1, ..., D.\n\nThen ",
    "$$ p_k(d) = f(X \\ge k \\; | \\; \\theta, d) = \\begin{cases} 1 & k = 0 \\\\ ",
    "\\frac{", z, "}{1 + ", z, "} & k=1, ..., K",
    "\\end{cases} $$\n\n",
    "where d* denotes a reference dose.\n\nThe &alpha;s are constrained ",
    "such that &alpha;~1~ > &alpha;~2~ > ... > &alpha;~K~.\n\n"
  )
}

#' @description `r lifecycle::badge("experimental")`
#' @rdname knit_print
#' @export
#' @method knit_print LogisticLogNormalOrdinal
knit_print.LogisticLogNormalOrdinal <- function(
    x,
    ...,
    use_values = TRUE,
    fmt = "%5.2f",
    params = NA,
    preamble = "The prior for &theta; is given by\\n",
    asis = TRUE) {
  assert_flag(asis)
  if (is.na(params)) {
    params <- c(
      paste0("alpha_", 1:(length(x@params@mean) - 1)),
      "beta"
    )
    names(params) <- paste0("\\", params)
  }
  NextMethod(params = params)
}

#' @include helpers.R
#' @include Data-class.R
#' @include Simulations-validity.R
#' @include CrmPackClass-class.R
NULL

# GeneralSimulations ----

## class ----

#' `GeneralSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures trial simulations.
#' Here also the random generator state before starting the simulation is
#' saved, in order to be able to reproduce the outcome. For this just use
#' [`set.seed`] with the `seed` as argument before running
#' [`simulate,Design-method`].
#'
#' @slot data (`list`)\cr produced [`Data`] objects.
#' @slot doses (`numeric`)\cr final dose recommendations.
#' @slot seed (`integer`)\cr random generator state before starting the simulation.
#'
#' @aliases GeneralSimulations
#' @export
.GeneralSimulations <-
  setClass(
    Class = "GeneralSimulations",
    slots = c(
      data = "list",
      doses = "numeric",
      seed = "integer"
    ),
    prototype = prototype(
      data =
        list(
          Data(
            x = 1:2,
            y = 0:1,
            doseGrid = 1:2,
            ID = 1L:2L,
            cohort = 1L:2L
          ),
          Data(
            x = 3:4,
            y = 0:1,
            doseGrid = 3:4,
            ID = 1L:2L,
            cohort = 1L:2L
          )
        ),
      doses = c(1, 2),
      seed = 1L
    ),
    contains = "CrmPackClass",
    validity = v_general_simulations
  )

## constructor ----

#' @rdname GeneralSimulations-class
#'
#' @param data (`list`)\cr see slot definition.
#' @param doses (`numeric`)\cr see slot definition.
#' @param seed (`integer`)\cr see slot definition.
#'
#' @example examples/Simulations-class-GeneralSimulations.R
#' @export
GeneralSimulations <- function(data,
                               doses,
                               seed) {
  assert_integerish(seed)
  .GeneralSimulations(
    data = data,
    doses = doses,
    seed = as.integer(seed)
  )
}


## default constructor

#' @rdname GeneralSimulations-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulations()` function.
#' @export
.DefaultGeneralSimulations <- function() {
  GeneralSimulations(
    data = list(
      Data(x = 1:3, y = c(0, 1, 0), doseGrid = 1:3, ID = 1L:3L, cohort = 1L:3L),
      Data(x = 4:6, y = c(0, 1, 0), doseGrid = 4:6, ID = 1L:3L, cohort = 1L:3L)
    ),
    doses = c(1, 2),
    seed = 123
  )
}


# Simulations ----

## class ----

#' `Simulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from model based designs.
#' Additional slots `fit`, `stop_reasons`, `stop_report`,`additional_stats` compared to
#' the general class [`GeneralSimulations`].
#'
#' @slot fit (`list`)\cr final fits
#' @slot stop_reasons (`list`)\cr stopping reasons for each simulation run
#' @slot stop_report matrix of stopping rule outcomes
#' @slot additional_stats list of additional statistical summary
#' @aliases Simulations
#' @export
.Simulations <-
  setClass(
    Class = "Simulations",
    slots = c(
      fit = "list",
      stop_report = "matrix",
      stop_reasons = "list",
      additional_stats = "list"
    ),
    prototype = prototype(
      fit =
        list(
          c(0.1, 0.2),
          c(0.1, 0.2)
        ),
      stop_report = matrix(TRUE, nrow = 2),
      stop_reasons =
        list("A", "A"),
      additional_stats =
        list(a = 1, b = 1)
    ),
    contains = "GeneralSimulations",
    validity = v_simulations
  )

## constructor ----

#' @rdname Simulations-class
#'
#' @param fit (`list`)\cr see slot definition.
#' @param stop_reasons (`list`)\cr see slot definition.
#' @param stop_report see [`Simulations`]
#' @param additional_stats (`list`)\cr see slot definition.
#' @param \dots additional parameters from [`GeneralSimulations`]
#'
#' @example examples/Simulations-class-Simulations.R
#' @export
Simulations <- function(fit,
                        stop_reasons,
                        stop_report,
                        additional_stats,
                        ...) {
  start <- GeneralSimulations(...)
  .Simulations(start,
    fit = fit,
    stop_report = stop_report,
    stop_reasons = stop_reasons,
    additional_stats = additional_stats
  )
}

## default constructor ----

#' @rdname Simulations-class
#' @note Typically, end users will not use the `.DefaultSimulations()` function.
#' @export
.DefaultSimulations <- function() {
  design <- .DefaultDesign()
  myTruth <- probFunction(design@model, alpha0 = 7, alpha1 = 8)

  simulate(
    design,
    args = NULL,
    truth = myTruth,
    nsim = 1,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    parallel = FALSE
  )
}

# DualSimulations ----

## class ----

#' `DualSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the trial simulations from dual-endpoint model based
#' designs. In comparison to the parent class [`Simulations`],
#' it contains additional slots to capture the dose-biomarker `fits`, and the
#' `sigma2W` and `rho` estimates.
#'
#' @slot rho_est (`numeric`)\cr vector of final posterior median rho estimates
#' @slot sigma2w_est (`numeric`)\cr vector of final posterior median sigma2W estimates
#' @slot fit_biomarker (`list`)\cr with the final dose-biomarker curve fits
#' @aliases DualSimulations
#' @export
.DualSimulations <-
  setClass(
    Class = "DualSimulations",
    slots = c(
      rho_est = "numeric",
      sigma2w_est = "numeric",
      fit_biomarker = "list"
    ),
    prototype = prototype(
      rho_est = c(0.2, 0.3),
      sigma2w_est = c(0.2, 0.3),
      fit_biomarker =
        list(
          c(0.1, 0.2),
          c(0.1, 0.2)
        )
    ),
    contains = "Simulations",
    validity = v_dual_simulations
  )


## constructor ----

#' @rdname DualSimulations-class
#'
#' @param rho_est (`numeric`)\cr see [`DualSimulations`]
#' @param sigma2w_est (`numeric`)\cr [`DualSimulations`]
#' @param fit_biomarker (`list`)\cr see [`DualSimulations`]
#' @param \dots additional parameters from [`Simulations`]
#'
#' @example examples/Simulations-class-DualSimulations.R
#' @export
DualSimulations <- function(rho_est,
                            sigma2w_est,
                            fit_biomarker,
                            ...) {
  start <- Simulations(...)
  .DualSimulations(start,
    rho_est = rho_est,
    sigma2w_est = sigma2w_est,
    fit_biomarker = fit_biomarker
  )
}

## default constructor ----

#' @rdname DualSimulations-class
#' @note Typically, end users will not use the `.DefaultDualSimulations()` function.
#' @export
.DefaultDualSimulations <- function() {
  DualSimulations(
    rho_est = c(0.25, 0.35),
    sigma2w_est = c(0.15, 0.25),
    fit_biomarker = list(c(0.3, 0.4), c(0.4, 0.5)),
    fit = list(
      c(0.1, 0.2),
      c(0.3, 0.4)
    ),
    stop_report = matrix(c(TRUE, FALSE), nrow = 2),
    stop_reasons = list("A", "B"),
    additional_stats = list(a = 1, b = 1),
    data = list(
      Data(
        x = 1:2,
        y = 0:1,
        doseGrid = 1:2,
        ID = 1L:2L,
        cohort = 1L:2L
      ),
      Data(
        x = 3:4,
        y = 0:1,
        doseGrid = 3:4,
        ID = 1L:2L,
        cohort = 1L:2L
      )
    ),
    doses = c(1, 2),
    seed = 123L
  )
}

#' `GeneralSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This class captures the summary of general simulations output. Note that objects
#' should not be created by users, therefore no initialization
#' function is provided for this class.
#'
#' @slot target (`numeric`)\cr target toxicity interval
#' @slot target_dose_interval (`numeric`)\cr corresponding target dose interval
#' @slot nsim (`integer`)\cr number of simulations
#' @slot prop_dlts (`ANY`)\cr A numeric array (multi-dimensional) or list representing proportions of DLTs in the trials
#' @slot mean_tox_risk (`numeric`)\cr mean toxicity risks for the patients
#' @slot dose_selected (`numeric`)\cr doses selected as MTD
#' @slot tox_at_doses_selected (`numeric`)\cr true toxicity at doses selected
#' @slot prop_at_target (`numeric`)\cr Proportion of trials selecting target MTD
#' @slot dose_most_selected (`numeric`)\cr dose most often selected as MTD
#' @slot obs_tox_rate_at_dose_most_selected (`numeric`)\cr observed toxicity rate at dose most often selected
#' @slot n_obs (`ANY`)\cr A numeric array (multi-dimensional) or list representing number of patients overall.
#' @slot n_above_target (`integer`)\cr number of patients treated above target tox interval
#' @slot dose_grid (`numeric`)\cr the dose grid that has been used
#' @slot placebo (`logical`)\cr set to TRUE (default is FALSE) for a design with placebo
#' @aliases GeneralSimulationsSummary
#' @export
.GeneralSimulationsSummary <-
  setClass(
    Class = "GeneralSimulationsSummary",
    slots = c(
      target = "numeric",
      target_dose_interval = "numeric",
      nsim = "integer",
      prop_dlts = "ANY",
      mean_tox_risk = "numeric",
      dose_selected = "numeric",
      tox_at_doses_selected = "numeric",
      prop_at_target = "numeric",
      dose_most_selected = "numeric",
      obs_tox_rate_at_dose_most_selected = "numeric",
      n_obs = "ANY",
      n_above_target = "integer",
      dose_grid = "numeric",
      placebo = "logical"
    )
  )

## default constructor ----

#' @rdname GeneralSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultGeneralSimulationsSummary()` function.
#' @export
.DefaultGeneralSimulationsSummary <- function() {
  stop(
    paste(
      "Class GeneralSimulationsSummary cannot be instantiated directly.",
      "Please use one of its subclasses instead."
    )
  )
}

## SimulationsSummary ----

## class ----

#' `SimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' In addition to the slots in the parent class [`GeneralSimulationsSummary`],
#' it contains two slots with model fit information.
#'
#' @slot stop_report (`matrix`)\cr matrix of stopping rule outcomes
#' @slot fit_at_dose_most_selected (`numeric`)\cr fitted toxicity rate at dose most often selected
#' @slot additional_stats (`list`)\cr list of additional statistical summary
#' @slot mean_fit (`list`)\cr list with the average, lower (2.5%) and upper (97.5%)
#' quantiles of the mean fitted toxicity at each dose level
#'
#' @aliases SimulationsSummary
#' @export
.SimulationsSummary <-
  setClass(
    Class = "SimulationsSummary",
    slots = c(
      stop_report = "matrix",
      fit_at_dose_most_selected = "numeric",
      additional_stats = "list",
      mean_fit = "list"
    ),
    contains = "GeneralSimulationsSummary"
  )

## default constructor ----

#' @rdname SimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultSimulationsSummary()` function.
#' @export
.DefaultSimulationsSummary <- function() {
  stop(paste(
    "Class SimulationsSummary cannot be instantiated directly.",
    "Please use one of its subclasses instead."
  ))
}

# DualSimulationsSummary ----

# class ----

#' `DualSimulationsSummary`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures the summary of dual-endpoint simulations output.
#' In comparison to its parent class [`SimulationsSummary`], it has additional slots.
#'
#' @slot biomarker_fit_at_dose_most_selected (`numeric`)\cr fitted biomarker level at most often selected dose.
#' @slot mean_biomarker_fit (`list`)\cr list with average, lower (2.5%) and upper (97.5%) quantiles of
#' mean fitted biomarker level at each dose
#' @aliases DualSimulationsSummary
#' @export
.DualSimulationsSummary <-
  setClass(
    Class = "DualSimulationsSummary",
    slots = c(
      biomarker_fit_at_dose_most_selected = "numeric",
      mean_biomarker_fit = "list"
    ),
    contains = "SimulationsSummary"
  )

# default constructor

#' @rdname DualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultDualSimulationsSummary()` function.
#' @export
.DefaultDualSimulationsSummary <- function() {
  empty_data <- DataDual(doseGrid = c(1, 3, 5, 10, 15, 20, 25, 30))

  my_model <- DualEndpointRW(
    mean = c(0, 1),
    cov = matrix(c(1, 0, 0, 1), nrow = 2),
    sigma2betaW = 0.01,
    sigma2W = c(a = 0.1, b = 0.1),
    rho = c(a = 1, b = 1),
    rw1 = TRUE
  )

  my_next_best <- NextBestDualEndpoint(
    target = c(0.9, 1),
    overdose = c(0.35, 1),
    max_overdose_prob = 0.25
  )

  my_size1 <- CohortSizeRange(
    intervals = c(0, 30),
    cohort_size = c(1, 3)
  )
  my_size2 <- CohortSizeDLT(
    intervals = c(0, 1),
    cohort_size = c(1, 3)
  )
  my_size <- maxSize(my_size1, my_size2)

  my_stopping1 <- StoppingTargetBiomarker(
    target = c(0.9, 1),
    prob = 0.5
  )

  my_stopping <- my_stopping1 | StoppingMinPatients(10) | StoppingMissingDose()

  my_increments <- IncrementsRelative(
    intervals = c(0, 20),
    increments = c(1, 0.33)
  )

  my_design <- DualDesign(
    model = my_model,
    data = empty_data,
    nextBest = my_next_best,
    stopping = my_stopping,
    increments = my_increments,
    cohort_size = CohortSizeConst(3),
    startingDose = 3
  )

  beta_mod <- function(dose, e0, eMax, delta1, delta2, scal) {
    maxDens <- (delta1^delta1) * (delta2^delta2) / ((delta1 + delta2)^(delta1 + delta2))
    dose <- dose / scal
    e0 + eMax / maxDens * (dose^delta1) * (1 - dose)^delta2
  }

  true_biomarker <- function(dose) {
    beta_mod(dose, e0 = 0.2, eMax = 0.6, delta1 = 5, delta2 = 5 * 0.5 / 0.5, scal = 100)
  }

  true_tox <- function(dose) {
    pnorm((dose - 60) / 10)
  }

  x <- simulate(
    object = my_design,
    trueTox = true_tox,
    trueBiomarker = true_biomarker,
    sigma2W = 0.01,
    rho = 0,
    nsim = 1,
    parallel = FALSE,
    seed = 3,
    startingDose = 6,
    mcmcOptions = .DefaultMcmcOptions()
  )
}

# PseudoSimulations ----

## class ----

#' `PseudoSimulations`
#'
#' @description `r lifecycle::badge("stable")`
#' This class captures trial simulations from designs using pseudo model.
#' It has additional slots `fit` and `stop_reasons` compared to the
#' general class [`GeneralSimulations`].
#'
#' @slot fit (`list`)\cr final fit values.
#' @slot final_td_target_during_trial_estimates (`numeric`)\cr final estimates of the `td_target_during_trial`.
#' @slot final_td_target_end_of_trial_estimates (`numeric`)\cr final estimates of the `td_target_end_of_trial`.
#' @slot final_td_target_during_trial_at_dose_grid (`numeric`)
#'        \cr dose levels at dose grid closest below the final `td_target_during_trial` estimates.
#' @slot final_td_target_end_of_trial_at_dose_grid (`numeric`)
#'        \cr dose levels at dose grid closest below the final `td_target_end_of_trial` estimates.
#' @slot final_tdeot_cis (`list`)\cr 95% credibility intervals of the final estimates for `td_target_end_of_trial`.
#' @slot final_tdeot_ratios (`numeric`)\cr ratio of the upper to the lower 95%
#'        credibility intervals for `td_target_end_of_trial`.
#' @slot final_cis (`list`)\cr final 95% credibility intervals for `td_target_end_of_trial` estimates.
#' @slot final_ratios (`numeric`)\cr final ratios of the upper to the lower 95%
#'        credibility interval for `td_target_end_of_trial`.
#' @slot stop_report (`matrix`)\cr outcomes of stopping rules.
#' @slot stop_reasons (`list`)\cr reasons for stopping each simulation run.
#'
#' @aliases PseudoSimulations
#' @export
.PseudoSimulations <-
  setClass(
    Class = "PseudoSimulations",
    slots = c(
      fit = "list",
      final_td_target_during_trial_estimates = "numeric",
      final_td_target_end_of_trial_estimates = "numeric",
      final_td_target_during_trial_at_dose_grid = "numeric",
      final_td_target_end_of_trial_at_dose_grid = "numeric",
      final_tdeot_cis = "list",
      final_tdeot_ratios = "numeric",
      final_cis = "list",
      final_ratios = "numeric",
      stop_report = "matrix",
      stop_reasons = "list"
    ),
    prototype = prototype(
      final_td_target_during_trial_estimates = c(0.1, 0.1),
      final_td_target_end_of_trial_estimates = c(0.1, 0.1),
      final_td_target_during_trial_at_dose_grid = c(0.1, 0.1),
      final_td_target_end_of_trial_at_dose_grid = c(0.1, 0.1),
      final_tdeot_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_tdeot_ratios = c(0.1, 0.1),
      final_cis = list(c(0.1, 0.2), c(0.1, 0.2)),
      final_ratios = c(0.1, 0.1),
      stop_report = matrix(TRUE, nrow = 2),
      stop_reasons = list("A", "A")
    ),
    contains = "GeneralSimulations",
    validity = v_pseudo_simulations
  )

## constructor ----

#' @rdname PseudoSimulations-class
#'
#' @param fit (`list`)\cr see slot definition.
#' @param final_td_target_during_trial_estimates (`numeric`)\cr see slot definition.
#' @param final_td_target_end_of_trial_estimates (`numeric`)\cr see slot definition.
#' @param final_td_target_during_trial_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_td_target_end_of_trial_at_dose_grid (`numeric`)\cr see slot definition.
#' @param final_tdeot_cis (`list`)\cr see slot definition.
#' @param final_tdeot_ratios (`numeric`)\cr see slot definition.
#' @param final_cis (`list`)\cr see slot definition.
#' @param final_ratios (`numeric`)\cr see slot definition.
#' @param stop_report see [`PseudoSimulations`]
#' @param stop_reasons (`list`)\cr see slot definition.
#' @param \dots additional parameters from [`GeneralSimulations`]
#'
#' @export
PseudoSimulations <- function(fit,
                              final_td_target_during_trial_estimates,
                              final_td_target_end_of_trial_estimates,
                              final_td_target_during_trial_at_dose_grid,
                              final_td_target_end_of_trial_at_dose_grid,
                              final_tdeot_cis,
                              final_tdeot_ratios,
                              final_cis,
                              final_ratios,
                              stop_report,
                              stop_reasons,
                              ...) {
  start <- GeneralSimulations(...)
  .PseudoSimulations(start,
    fit = fit,
    final_td_target_during_trial_estimates = final_td_target_during_trial_estimates,
    final_td_target_end_of_trial_estimates = final_td_target_end_of_trial_estimates,
    final_td_target_during_trial_at_dose_grid = final_td_target_during_trial_at_dose_grid,
    final_td_target_end_of_trial_at_dose_grid = final_td_target_end_of_trial_at_dose_grid,
    final_tdeot_cis = final_tdeot_cis,
    final_tdeot_ratios = final_tdeot_ratios,
    final_cis = final_cis,
    final_ratios = final_ratios,
    stop_report = stop_report,
    stop_reasons = stop_reasons
  )
}

## default constructor ----

#' @rdname PseudoSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulations()` function.
#' @export
.DefaultPseudoSimulations <- function() {
  stop("Class PseudoSimulations cannot be instantiated directly. Please use one of its subclasses instead.")
}

# nolint start
## ===============================================================================
## -------------------------------------------------------------------------------
## Class for Pseudo simulation using DLE and efficacy responses (Pseudo models except 'EffFlexi' model)
## -----------------------------------------------------------------------------------

##' Class `PseudoDualSimulations`
##'
##' This is a class which captures the trial simulations design using both the
##' DLE and efficacy responses. The design of model from \code{\linkS4class{ModelTox}}
##' class and the efficacy model from \code{\linkS4class{ModelEff}} class
##' (except \code{\linkS4class{EffFlexi}} class). It contains all slots from
##' \code{\linkS4class{GeneralSimulations}} and \code{\linkS4class{PseudoSimulations}} object.
##' In comparison to the parent class \code{\linkS4class{PseudoSimulations}},
##' it contains additional slots to
##' capture the dose-efficacy curve and the sigma2 estimates.
##'
##' @slot fitEff list of the final values. If DLE and efficacy samples are generated, it contains the
##' final fitted values. If no DLE and efficacy samples are used, it contains the modal estimates of the
##' parameters in the two models and the posterior estimates of the probabilities of the occurrence of a
##' DLE and the expected efficacy responses.
##' @slot FinalGstarEstimates a vector of the final estimates of Gstar at the end of each simulations.
##' @slot FinalGstarAtDoseGrid is a vector of the final estimates of Gstar at dose Grid at the end of each simulations
##' @slot FinalGstarCIs is the list of all 95% credibility interval of the final estimates of Gstar
##' @slot FinalGstarRatios is the vector of the ratios of the CI, the ratio of the upper to the lower 95% credibility interval
##' of the final estimates of Gstar
##' @slot FinalOptimalDose is the vector of the final optimal dose, the minimum of the final TDtargetEndOfTrial estimates and Gstar
##' estimates
##' @slot FinalOptimalDoseAtDoseGrid is the vector of the final optimal dose, the minimum of the final TDtargetEndOfTrial estimates
##' and Gstar estimates at dose Grid
##' @slot sigma2est the vector of the final posterior mean sigma2 estimates
##'
##' @export
.PseudoDualSimulations <-
  setClass(
    Class = "PseudoDualSimulations",
    representation(
      fitEff = "list",
      FinalGstarEstimates = "numeric",
      FinalGstarAtDoseGrid = "numeric",
      FinalGstarCIs = "list",
      FinalGstarRatios = "numeric",
      FinalOptimalDose = "numeric",
      FinalOptimalDoseAtDoseGrid = "numeric",
      sigma2est = "numeric"
    ),
    prototype(
      FinalGstarEstimates = c(0.1, 0.1),
      FinalGstarAtDoseGrid = c(0.1, 0.1),
      FinalGstarCIs = list(
        c(0.1, 0.2),
        c(0.1, 0.2)
      ),
      FinalGstarRatios = c(0.01, 0.01),
      FinalOptimalDose = c(0.01, 0.01),
      FinalOptimalDoseAtDoseGrid = c(0.01, 0.01),
      sigma2est = c(0.001, 0.002)
    ),
    contains = "PseudoSimulations",
    validity = v_pseudo_dual_simulations
  )

validObject(.PseudoDualSimulations())

##' Initialization function for 'DualPseudoSimulations' class
##' @param fitEff please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param  FinalGstarEstimates please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalGstarAtDoseGrid please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalGstarCIs please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalGstarRatios please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalOptimalDose please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param FinalOptimalDoseAtDoseGrid please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param sigma2est please refer to \code{\linkS4class{PseudoDualSimulations}} class object
##' @param \dots additional parameters from \code{\linkS4class{PseudoSimulations}}
##' @return the \code{\linkS4class{PseudoDualSimulations}} object
PseudoDualSimulations <- function(fitEff,
                                  FinalGstarEstimates,
                                  FinalGstarAtDoseGrid,
                                  FinalGstarCIs,
                                  FinalGstarRatios,
                                  FinalOptimalDose,
                                  FinalOptimalDoseAtDoseGrid,
                                  sigma2est,
                                  ...) {
  start <- PseudoSimulations(...)
  .PseudoDualSimulations(start,
    fitEff = fitEff,
    FinalGstarEstimates = FinalGstarEstimates,
    FinalGstarAtDoseGrid = FinalGstarAtDoseGrid,
    FinalGstarCIs = FinalGstarCIs,
    FinalGstarRatios = FinalGstarRatios,
    FinalOptimalDose = FinalOptimalDose,
    FinalOptimalDoseAtDoseGrid = FinalOptimalDoseAtDoseGrid,
    sigma2est = sigma2est
  )
}

## default constructor ----

#' @rdname PseudoDualSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoDualSimulations()` function.
#' @export
.DefaultPseudoDualSimulations <- function() {
  stop(paste0("Class PseudoDualSimulations cannot be instantiated directly.  Please use one of its subclasses instead."))
}

# PseudoDualFlexiSimulations ----

## class ----

## -------------------------------------------------------------------------------
## Class for Pseudo simulation using DLE and efficacy responses using 'EffFlex' efficacy model
## -----------------------------------------------------------------------------------
##' This is a class which captures the trial simulations design using both the
##' DLE and efficacy responses. The design of model from \code{\linkS4class{ModelTox}}
##' class and the efficacy model from \code{\linkS4class{EffFlexi}} class
##'  It contains all slots from
##' \code{\linkS4class{GeneralSimulations}}, \code{\linkS4class{PseudoSimulations}}
##' and \code{\linkS4class{PseudoDualSimulations}} object.
##' In comparison to the parent class \code{\linkS4class{PseudoDualSimulations}},
##' it contains additional slots to
##' capture the sigma2betaW estimates.
##'
##' @slot sigma2betaWest the vector of the final posterior mean sigma2betaW estimates
##'
##' @export
##' @keywords class
.PseudoDualFlexiSimulations <-
  setClass(
    Class = "PseudoDualFlexiSimulations",
    representation(sigma2betaWest = "numeric"),
    prototype(sigma2betaWest = c(0.001, 0.002)),
    contains = "PseudoDualSimulations",
    validity = v_pseudo_dual_flex_simulations
  )

validObject(.PseudoDualFlexiSimulations())

##' Initialization function for 'PseudoDualFlexiSimulations' class
##' @param sigma2betaWest please refer to \code{\linkS4class{PseudoDualFlexiSimulations}} class object
##' @param \dots additional parameters from \code{\linkS4class{PseudoDualSimulations}}
##' @return the \code{\linkS4class{PseudoDualFlexiSimulations}} object
PseudoDualFlexiSimulations <- function(sigma2betaWest,
                                       ...) {
  start <- PseudoDualSimulations(...)
  .PseudoDualFlexiSimulations(start,
    sigma2betaWest = sigma2betaWest
  )
}

## default constructor ----

#' @rdname PseudoDualFlexiSimulations-class
#' @note Typically, end users will not use the `.DefaultPseudoFlexiSimulations()` function.
#' @export
.DefaultPseudoDualFlexiSimulations <- function() {
  stop(paste0("Class PseudoFlexiSimulations cannot be instantiated directly.  Please use one of its subclasses instead."))
}

## -------------------------------------------------------------------------------------------------------
## ================================================================================================

##' Class for the summary of pseudo-models simulations output
##'
##' Note that objects should not be created by users, therefore no
##' initialization function is provided for this class.
##'
##' @slot targetEndOfTrial the target probability of DLE wanted at the end of a trial
##' @slot targetDoseEndOfTrial the dose level corresponds to the target probability
##' of DLE wanted at the end of a trial, TDEOT
##' @slot targetDoseEndOfTrialAtDoseGrid the dose level at dose grid corresponds to the target probability
##' of DLE wanted at the end of a trial
##' @slot targetDuringTrial the target probability of DLE wanted during a trial
##' @slot targetDoseDuringTrial the dose level corresponds to the target probability of DLE
##' wanted during the trial. TDDT
##' @slot targetDoseDuringTrialAtDoseGrid the dose level at dose grid corresponds to the target probability
##' of DLE wanted during a trial
##' @slot TDEOTSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final dose levels obtained corresponds to the target probability of DLE
##' want at the end of a trial across all simulations
##' @slot TDDTSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final dose levels obtained corresponds to the target probability of DLE
##' want during a trial across all simulations
##' @slot FinalDoseRecSummary the six-number table summary, include the lowest, the 25th precentile (lower quartile),
##' the 50th percentile (median), the mean, the 27th percentile and the highest values of the
##' final optimal doses, which is either the TDEOT when only DLE response are incorporated into
##' the escalation procedure or the minimum of the TDEOT and Gstar when DLE and efficacy responses are
##' incorporated, across all simulations
##' @slot ratioTDEOTSummary the six-number summary table of the final ratios of the upper to the lower 95%
##' credibility intervals of the final TDEOTs across all simulations
##' @slot FinalRatioSummary the six-number summary table of the final ratios of the upper to the lower 95%
##' credibility intervals of the final optimal doses across all simulations
##' #@slot doseRec the dose level that will be recommend for subsequent study
##' @slot nsim number of simulations
##' @slot propDLE proportions of DLE in the trials
##' @slot meanToxRisk mean toxicity risks for the patients
##' @slot doseSelected doses selected as MTD (targetDoseEndOfTrial)
##' @slot toxAtDosesSelected true toxicity at doses selected
##' @slot propAtTargetEndOfTrial Proportion of trials selecting at the doseGrid closest below the MTD, the
##' targetDoseEndOfTrial
##' @slot propAtTargetDuringTrial Proportion of trials selecting at the doseGrid closest below the
##' targetDoseDuringTrial
##' @slot doseMostSelected dose most often selected as MTD
##' @slot obsToxRateAtDoseMostSelected observed toxicity rate at dose most often
##' selected
##' @slot nObs number of patients overall
##' @slot nAboveTargetEndOfTrial number of patients treated above targetDoseEndOfTrial
##' @slot nAboveTargetDuringTrial number of patients treated above targetDoseDuringTrial
##' @slot doseGrid the dose grid that has been used
##' @slot fitAtDoseMostSelected fitted toxicity rate at dose most often selected
##' @slot meanFit list with the average, lower (2.5%) and upper (97.5%)
##' quantiles of the mean fitted toxicity at each dose level
##' @slot stop_report matrix of stopping rule outcomes
##'
##' @export
##' @keywords classes
.PseudoSimulationsSummary <-
  setClass(
    Class = "PseudoSimulationsSummary",
    representation(
      targetEndOfTrial = "numeric",
      targetDoseEndOfTrial = "numeric",
      targetDoseEndOfTrialAtDoseGrid = "numeric",
      targetDuringTrial = "numeric",
      targetDoseDuringTrial = "numeric",
      targetDoseDuringTrialAtDoseGrid = "numeric",
      TDEOTSummary = "table",
      TDDTSummary = "table",
      FinalDoseRecSummary = "table",
      ratioTDEOTSummary = "table",
      FinalRatioSummary = "table",
      # doseRec="numeric",
      nsim = "integer",
      propDLE = "numeric",
      meanToxRisk = "numeric",
      doseSelected = "numeric",
      toxAtDosesSelected = "numeric",
      propAtTargetEndOfTrial = "numeric",
      propAtTargetDuringTrial = "numeric",
      doseMostSelected = "numeric",
      obsToxRateAtDoseMostSelected = "numeric",
      nObs = "integer",
      nAboveTargetEndOfTrial = "integer",
      nAboveTargetDuringTrial = "integer",
      doseGrid = "numeric",
      fitAtDoseMostSelected = "numeric",
      meanFit = "list",
      stop_report = "matrix"
    )
  )

## default constructor ----

#' @rdname GeneralSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoSimulationsSummary()` function.
#' @export
.DefaultPseudoSimulationsSummary <- function() {
  stop(paste0("Class PseudoSimulationsSummary cannot be instantiated directly.  Please use one of its subclasses instead."))
}

## ---------------------------------------------------------------------------------------------
##' Class for the summary of the dual responses simulations using pseudo models
##'
##' It contains all slots from \code{\linkS4class{PseudoSimulationsSummary}} object. In addition to
##' the slots in the parent class \code{\linkS4class{PseudoSimulationsSummary}}, it contains four
##' more slots for the efficacy model fit information.
##'
##' Note that objects should not be created by users, therefore no initialization function
##' is provided for this class.
##'
##' @slot targetGstar the target dose level such that its gain value is at maximum
##' @slot targetGstarAtDoseGrid the dose level at dose Grid closest and below Gstar
##' @slot GstarSummary the six-number table summary (lowest, 25th, 50th (median), 75th percentile, mean
##' and highest value) of the final Gstar values obtained across all simulations
##' @slot ratioGstarSummary the six-number summary table of the ratios of the upper to the lower 95%
##' credibility intervals of the final Gstar across all simulations
##' @slot EffFitAtDoseMostSelected fitted expected mean efficacy value at dose most often
##' selected
##' @slot meanEffFit list with mean, lower (2.5%) and upper (97.5%) quantiles of the fitted expected
##' efficacy value at each dose level.
##'
##' @export
##' @keywords class
.PseudoDualSimulationsSummary <-
  setClass(
    Class = "PseudoDualSimulationsSummary",
    contains = "PseudoSimulationsSummary",
    representation =
      representation(
        targetGstar = "numeric",
        targetGstarAtDoseGrid = "numeric",
        GstarSummary = "table",
        ratioGstarSummary = "table",
        EffFitAtDoseMostSelected = "numeric",
        meanEffFit = "list"
      )
  )

## default constructor ----

#' @rdname PseudoDualSimulationsSummary-class
#' @note Typically, end users will not use the `.DefaultPseudoDualSimulationsSummary()` function.
#' @export
.DefaultPseudoDualSimulationsSummary <- function() {
  stop(paste0("Class PseudoDualSimulationsSummary cannot be instantiated directly.  Please use one of its subclasses instead."))
}

## ---------------------------------------------------------------------------------------------

##' Class for the simulations output from DA based designs
##'
##' This class captures the trial simulations from DA based
##' designs. In comparison to the parent class \code{\linkS4class{Simulations}},
##' it contains additional slots to capture the time to DLT fits, additional
##' parameters and the trial duration.
##'
##' @slot trialduration the vector of trial duration values for all simulations.
##'
##' @export
##' @keywords classes
.DASimulations <-
  setClass(
    Class = "DASimulations",
    representation(trialduration = "numeric"),
    prototype(trialduration = rep(0, 2)),
    contains = "Simulations",
    validity = v_da_simulations
  )
validObject(.DASimulations())


##' Initialization function for `DASimulations`
##'
##' @param trialduration see \code{\linkS4class{DASimulations}}
##' @param \dots additional parameters from \code{\link{Simulations}}
##' @return the \code{\linkS4class{DASimulations}} object
##'
##' @export
##' @keywords methods
DASimulations <- function(trialduration,
                          ...) {
  start <- Simulations(...)
  .DASimulations(start,
    trialduration = trialduration
  )
}


## default constructor ----

#' @rdname DASimulations-class
#' @note Typically, end users will not use the `.DASimulations()` function.
#' @export
.DefaultDASimulations <- function() {
  design <- .DefaultDADesign()
  myTruth <- probFunction(design@model, alpha0 = 2, alpha1 = 3)
  exp_cond.cdf <- function(x, onset = 15) {
    a <- stats::pexp(28, 1 / onset, lower.tail = FALSE)
    1 - (stats::pexp(x, 1 / onset, lower.tail = FALSE) - a) / (1 - a)
  }

  simulate(
    design,
    args = NULL,
    truthTox = myTruth,
    truthSurv = exp_cond.cdf,
    trueTmax = 80,
    nsim = 2,
    seed = 819,
    mcmcOptions = .DefaultMcmcOptions(),
    firstSeparate = TRUE,
    deescalate = FALSE,
    parallel = FALSE
  )
}
# nolint end

# tidy

## tidy-Simulations ----

#' @rdname tidy
#' @aliases tidy-Simulations
#' @example examples/Simulations-method-tidy.R
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "Simulations"),
  definition = function(x, ...) {
    slot_names <- slotNames(x)
    rv <- list()
    for (nm in slot_names) {
      if (!is.function(slot(x, nm))) {
        if (nm %in% c("stop_reasons", "additional_stats")) {
        } else {
          rv[[nm]] <- h_tidy_slot(x, nm)
        }
      }
    }
    # Column bind of all list elements have the same number of rows
    if (length(rv) > 1 & length(unique(sapply(rv, nrow))) == 1) {
      rv <- rv %>% dplyr::bind_cols()
    }
    rv %>% h_tidy_class(x)
  }
)

#' @include helpers_knitr_CohortSize.R

# Increments ----

#' Render a `IncrementsRelative` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by highest dose administered so far"`.  These
#' values can be overridden by passing `col.names` and `caption` in the function
#' call.
#' @export
#' @rdname knit_print
knit_print.IncrementsRelative <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by highest dose administered so far"
  }
  x <- tidy(x)
  param[["x"]] <- x
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("Dose" = 2, " " = 1)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeDLT` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by number of DLTs reported so far"`. These values
#' can be overridden by passing `col.names` and `caption` in the function call.
#' @export
#' @rdname knit_print
knit_print.IncrementsRelativeDLT <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by number of DLTs reported so far"
  }


  param[["x"]] <- tidy(x)
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("No DLTs" = 2, " " = 1)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsDoseLevels` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @rdname knit_print
knit_print.IncrementsDoseLevels <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The maximum increment between cohorts is ",
    x@levels,
    ifelse(x@levels == 1, " level", " levels"),
    " relative to the ",
    ifelse(x@basis_level == "last", "dose used in the previous cohort.", "highest dose used so far."),
    "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsHSRBeta` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @rdname knit_print
knit_print.IncrementsHSRBeta <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The maximum increment is defined by a hard safety rule, independent of the CRM model, ",
    " and based on a beta(", x@a, ", ", x@b, ") ",
    "prior with a target toxicity rate of ",
    x@target,
    " and a probability threshold of ",
    x@prob,
    ".\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsMin` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @rdname knit_print
knit_print.IncrementsMin <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "The minimum of the increments defined in the following rules:",
    paste0(
      lapply(
        x@increments_list,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    paste = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsOrdinal` object
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` method of the standard rule
#' @inheritParams knit_print.CohortSizeConst
#' @export
#' @rdname knit_print
knit_print.IncrementsOrdinal <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
    paste = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeParts` object
#'
#' @inherit knit_print.CohortSizeConst return
#' @param labels (`character`)\cr The word used to describe toxicities.  See
#' Usage Notes below.
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' `labels` defines how toxicities are described.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single toxicity and the second describes all other
#' toxicity counts.  If of length 1, the character `s` is appended to the value
#' describing a single toxicity.
#'
#' @export
#' @rdname knit_print
knit_print.IncrementsRelativeParts <- function(x, ..., asis = TRUE, labels = c("toxicity", "toxicities")) {
  assert_flag(asis)
  assert_character(labels, min.len = 1, max.len = 2, any.missing = FALSE)

  if (length(labels) == 1) {
    labels[2] <- paste0(labels[1], "s")
  }
  rv <- paste0(
    "The maximum increment in Part 1 is defined by the `part1Ladder` slot of ",
    "the associated `DataParts` object.\n\n",
    "If no ", labels[2], " are reported in Part 1, the starting dose for Part 2 ",
    "will be ",
    ifelse(
      x@clean_start == 0,
      "the highest dose used in Part 1.\n\n",
      paste0(
        x@clean_start,
        ifelse(abs(x@clean_start) == 1, " dose ", " doses "),
        ifelse(x@clean_start < 0, "below ", "above "),
        "the highest dose used in Part 1.\n\n"
      )
    ),
    "If one or more ", labels[2], " are reported in Part 1, the starting dose for Part 2 ",
    "will be ",
    ifelse(
      x@dlt_start == 0,
      "the highest dose used in Part 1.\n\n",
      paste0(
        abs(x@dlt_start),
        ifelse(abs(x@dlt_start) == 1, " dose ", " doses "),
        ifelse(x@dlt_start < 0, "below ", "above "),
        "the highest dose used in Part 1.\n\n"
      )
    ),
    "Once Part 2 has started, the maximum increment in dose levels will be based ",
    "on the number of ", labels[2], " reported so far, as described in the ",
    "following table:"
  )

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- paste0("Defined by the number of ", labels[2], " reported so far")
  }
  header <- c(2, 1)
  headerLabel <- labels[2]
  substr(headerLabel, 1, 1) <- toupper(substr(headerLabel, 1, 1))
  names(header) <- c(headerLabel, " ")
  param[["x"]] <- tibble(
    intervals = x@intervals
  ) %>%
    h_range_to_minmax(intervals) %>%
    tibble::add_column(increments = c(0, x@increments))
  d_tab <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    header
  )
  rv <- paste(rv, d_tab)
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render an `IncrementsRelativeDLTCurrent` object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param labels (`character`)\cr The word used to describe toxicities.  See
#' Usage Notes below.
#' @param ... passed to [knitr::kable()]
#' @inheritParams knit_print.CohortSizeConst
#' @section Usage Notes:
#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
#' of `caption` is `"Defined by number of DLTs in the current cohort"`. These values
#' can be overridden by passing `col.names` and `caption` in the function call.
#'
#' `labels` defines how toxicities are described.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a single toxicity and the second describes all other
#' toxicity counts.  If of length 1, the character `s` is appended to the value
#' describing a single toxicity.
#'
#' @export
#' @rdname knit_print
knit_print.IncrementsRelativeDLTCurrent <- function(x, ..., asis = TRUE, labels = c("DLT", "DLTs")) {
  assert_flag(asis)
  assert_character(labels, min.len = 1, max.len = 2, any.missing = FALSE)

  if (length(labels) == 1) {
    labels[2] <- paste0(labels[1], "s")
  }

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Min", "Max", "Increment")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by number of DLTs reported in the current cohort"
  }
  param[["x"]] <- tidy(x)
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("No DLTs" = 2, " " = 1)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingOrdinal ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingOrdinal
knit_print.StoppingOrdinal <- function(
    x,
    ...,
    asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMaxGainCIRatio ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMaxGainCIRatio
knit_print.StoppingMaxGainCIRatio <- function(
    x,
    ...,
    asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the ratio of the upper to the lower limit of the posterior 95% credible ",
    "interval for the probability of toxicity at the target dose (the smaller ",
    "of the MTD for ",
    100 * x@prob_target,
    "% target and GStar) is less than or equal to ",
    x@target_ratio,
    "."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingList ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param preamble (`character`)\cr the text that introduces the list of rules
#' @rdname knit_print
#' @export
#' @method knit_print StoppingList
knit_print.StoppingList <- function(
    x,
    ...,
    preamble = "If the result of applying the summary function to the following rules is `TRUE`:\n",
    asis = TRUE) {
  assert_flag(asis)
  assert_character(preamble, len = 1, any.missing = FALSE)

  rules_list <- paste0(
    lapply(
      x@stop_list,
      function(z) {
        paste0("-  ", knit_print(z, asis = FALSE, ...))
      }
    ),
    collapse = "\n"
  )
  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    preamble,
    "\n",
    rules_list
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingAny ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingList
#' @rdname knit_print
#' @export
#' @method knit_print StoppingAny
knit_print.StoppingAny <- function(
    x,
    ...,
    preamble = "If any of the following rules are `TRUE`:\n",
    asis = TRUE) {
  knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
}

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingList
#' @rdname knit_print
#' @export
#' @method knit_print StoppingAll
knit_print.StoppingAll <- function(
    x,
    ...,
    preamble = "If all of the following rules are `TRUE`:\n",
    asis = TRUE) {
  knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
}

# StoppingTDCIRatio ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTDCIRatio
knit_print.StoppingTDCIRatio <- function(
    x,
    ...,
    dose_label = "the next best dose",
    tox_label = "toxicity",
    fmt_string = paste0(
      "%sIf, at %s, the ratio of the upper to the lower limit of the posterior ",
      "95%% credible interval for %s (targetting %2.0f%%) is less than or equal to "
    ),
    asis = TRUE) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    sprintf(
      fmt_string,
      ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
      dose_label,
      tox_label,
      100 * x@prob_target
    ),
    x@target_ratio,
    "."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingTargetBiomarker ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTargetBiomarker
knit_print.StoppingTargetBiomarker <- function(
    x,
    ...,
    dose_label = "the next best dose",
    biomarker_label = "the target biomarker",
    fmt_string = paste0(
      "%sIf, at %s, the posterior probability that %s is in the range ",
      "(%.2f, %.2f)%s is %.0f%% or more."
    ),
    asis = TRUE) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)
  assert_character(biomarker_label, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    dose_label,
    biomarker_label,
    x@target[1],
    x@target[2],
    ifelse(
      x@is_relative,
      paste0(", relative to the maximum value of ", biomarker_label, ","),
      ""
    ),
    100 * x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingLowestDoseHSRBeta ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingLowestDoseHSRBeta
knit_print.StoppingLowestDoseHSRBeta <- function(
    x,
    ...,
    tox_label = "toxicity",
    fmt_string = paste0(
      "%sIf, using a Hard Stopping Rule with a prior of Beta(%.0f, %.0f), the ",
      "lowest dose in the dose grid has a posterior probability of %s of ",
      "%.0f%% or more."
    ),
    asis = TRUE) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    x@a,
    x@b,
    tox_label,
    100 * x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMTDCV ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMTDCV
knit_print.StoppingMTDCV <- function(
    x,
    ...,
    fmt_string = paste0(
      "%sIf the posterior estimate of the robust coefficient of variation of ",
      "the MTD (targetting %2.0f%%), is than or equal to %.0f%%."
    ),
    asis = TRUE) {
  assert_flag(asis)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    100 * x@target,
    100 * x@thresh_cv
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMTDdistribution ----

#' @description `r lifecycle::badge("experimental")`
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMTDdistribution
knit_print.StoppingMTDdistribution <- function(
    x,
    ...,
    fmt_string = "%sIf the mean posterior probability of %s at %.0f%% of %s is at least %4.2f.",
    dose_label = "the next best dose",
    tox_label = "toxicity",
    asis = TRUE) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    tox_label,
    100 * x@thresh,
    dose_label,
    x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingHighestDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingHighestDose
knit_print.StoppingHighestDose <- function(
    x,
    ...,
    dose_label = "the highest dose in the dose grid",
    asis = TRUE) {
  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the next best dose is ",
    dose_label, "."
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingSpecificDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingSpecificDose
knit_print.StoppingSpecificDose <- function(
    x,
    ...,
    dose_label = as.character(x@dose),
    asis = TRUE) {
  x@rule@report_label <- x@report_label
  knit_print(
    x@rule,
    ...,
    dose_label = dose_label,
    asis = asis
  )
}

# StoppingTargetProb ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @param fmt_string (`character`)\cr the character string that defines the format
#' of the output
#' @param dose_label (`character`)\cr the term used to describe the target dose
#' @param tox_label (`character`)\cr the term used to describe toxicity
#' @rdname knit_print
#' @export
#' @method knit_print StoppingTargetProb
knit_print.StoppingTargetProb <- function(
    x,
    ...,
    fmt_string = "%sIf the probability of %s at %s is in the range [%4.2f, %4.2f] is at least %4.2f.",
    dose_label = "the next best dose",
    tox_label = "toxicity",
    asis = TRUE) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)
  assert_character(tox_label, len = 1, any.missing = FALSE)
  assert_character(fmt_string, len = 1, any.missing = FALSE)

  rv <- sprintf(
    fmt_string,
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    tox_label,
    dose_label,
    x@target[1],
    x@target[2],
    x@prob
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMinCohorts ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMinCohorts
knit_print.StoppingMinCohorts <- function(
    x,
    ...,
    asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nCohorts,
    " or more cohorts have been treated."
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMinPatients ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr the term used to label participants
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMinPatients
knit_print.StoppingMinPatients <- function(
    x,
    ...,
    label = "participants",
    asis = TRUE) {
  assert_flag(asis)
  assert_character(label, len = 1, any.missing = FALSE)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nPatients,
    paste0(" or more ", label, " have been treated.")
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingPatientsNearDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param label (`character`)\cr the term used to label participants
#' @inheritParams knit_print.StoppingTargetProb
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingPatientsNearDose
knit_print.StoppingPatientsNearDose <- function(
    x,
    ...,
    dose_label = "the next best dose",
    label = "participants",
    asis = TRUE) {
  assert_flag(asis)
  assert_character(label, len = 1, any.missing = FALSE)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nPatients,
    paste0(" or more ", label, " have been treated "),
    ifelse(
      x@percentage == 0,
      "at ",
      paste0("within ", x@percentage, "% of ")
    ),
    dose_label,
    "."
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingCohortsNearDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @inheritParams knit_print.StoppingTargetProb
#' @rdname knit_print
#' @export
#' @method knit_print StoppingCohortsNearDose
knit_print.StoppingCohortsNearDose <- function(
    x,
    ...,
    dose_label = "the next best dose",
    asis = TRUE) {
  assert_flag(asis)
  assert_character(dose_label, len = 1, any.missing = FALSE)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If ",
    x@nCohorts,
    " or more cohorts have been treated ",
    ifelse(
      x@percentage == 0,
      "at ",
      paste0("within ", x@percentage, "% of ")
    ),
    dose_label,
    "."
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

# StoppingMissingDose ----

#' @description `r lifecycle::badge("experimental")`
#' @param asis (`flag`)\cr Not used at present
#' @rdname knit_print
#' @export
#' @method knit_print StoppingMissingDose
knit_print.StoppingMissingDose <- function(
    x,
    ...,
    asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
    "If the dose returned by <code>nextBest()</code> is ",
    "<code>NA</code>, or if the trial includes a placebo dose, the placebo dose."
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Helper Function to Blind Plot Data
#'
#' @param df (`GeneralData`)\cr The data to be blinded
#' @param blind (`flag`)\cr Should the data be blinded?
#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
#' Ignored if `has_placebo` is `FALSE`
#' @returns The blinded data
h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
  if (blind) {
    # This is to blind the data.
    # For each cohort, all DLTs are assigned to the first subjects in the cohort.
    # In addition, the placebo (if any) is set to the active dose level for that
    # cohort.
    # Notice: dapply reorders records of df according to the lexicographic order
    # of cohort.
    df <- dapply(df, f = ~cohort, FUN = function(coh) {
      coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
      coh$dose <- max(coh$dose)
      coh
    })
  } else if (has_placebo) {
    # Placebo will be plotted at y = 0 level.
    df$dose[df$dose == pbo_dose] <- 0
  }
  df
}

# h_plot_data_df ----

## generic ----

#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A method that transforms [`GeneralData`]  objects into a `tibble` suitable for
#' plotting with `ggplot2` methods
#'
#' @param data (`GeneralData`)\cr object from which data is extracted and converted
#' into a data frame.
#' @param ... further arguments passed to class-specific methods.
#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
#' @aliases h_plot_data_df
#'
setGeneric(
  name = "h_plot_data_df",
  def = function(data, ...) standardGeneric("h_plot_data_df"),
  valueClass = "data.frame"
)

# Data ----

#' Helper Function for the Plot Method of [`Data`]
#'
#' @param data (`Data`)\cr object from which data is extracted and converted
#'   into a data frame.
#' @param blind (`flag`)\cr should data be blinded?
#'   If `TRUE`, then for each cohort, all DLTs are assigned to the first
#'   subjects in the cohort. In addition, the placebo (if any) is set to the
#'   active dose level for that cohort.
#' @param legend (`flag`)\cr Display the legend for the toxicity categories
#' @param ... further arguments passed to `data.frame` constructor.
#'   It can be e.g. an extra `column_name = value` pair based on a slot
#'   from `x` (which in this case might be a subclass of `Data`)
#'   which does not appear in `Data`.
#' @return A `data.frame` object with columns patient, ID, cohort, dose and
#' toxicity.
#' @describeIn h_plot_data_df method for [`Data`].
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "Data"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = ifelse(data@y == 1, "Yes", "No"),
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)

# DataOrdinal ----

#' Helper Function for the Plot Method of [`DataOrdinal`]
#'
#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
setMethod(
  f = "h_plot_data_df",
  signature = signature(data = "DataOrdinal"),
  definition = function(data, blind = FALSE, legend = TRUE, ...) {
    df <- data.frame(
      patient = seq_along(data@x),
      ID = paste(" ", data@ID),
      cohort = data@cohort,
      dose = data@x,
      toxicity = names(data@yCategories)[1 + data@y],
      ...
    )
    df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
    df
  }
)


# h_plot_data_dataordinal

## Data ----

#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that creates a plot for [`Data`]  and [`DataOrdinal`] objects.
#'
#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
#' being displayed as red triangles and other responses as black circles.
#' @return The [`ggplot2`] object.
#'
#' @rdname plot-Data
h_plot_data_dataordinal <- function(
    x,
    blind = FALSE,
    legend = TRUE,
    tox_labels = c(Yes = "red", No = "black"),
    tox_shapes = c(Yes = 17L, No = 16L),
    ...) {
  assert_flag(blind)
  assert_flag(legend)
  assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
  assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
  assert_true(length(tox_shapes) == length(tox_labels))
  assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
  if (x@nObs == 0L) {
    return()
  }
  df <- h_plot_data_df(x, blind, ...)

  p <- ggplot(df, aes(x = patient, y = dose)) +
    geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
    scale_colour_manual(
      name = "Toxicity",
      values = tox_labels,
      breaks = names(tox_labels),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_shape_manual(
      name = "Toxicity",
      values = tox_shapes,
      breaks = names(tox_shapes),
      guide = guide_legend(reverse = TRUE)
    ) +
    scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
    scale_y_continuous(
      breaks = sort(unique(c(0, df$dose))),
      minor_breaks = NULL,
      limits = c(0, max(df$dose) * 1.1)
    ) +
    xlab("Patient") +
    ylab("Dose Level")

  p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)

  if (!blind) {
    p <- p +
      geom_text(
        aes(label = ID, size = 2),
        data = df,
        hjust = 0,
        vjust = 0.5,
        angle = 90,
        colour = "black",
        show.legend = FALSE
      )
  }

  if (!legend) {
    p <- p + theme(legend.position = "none")
  }

  p
}

#' Helper Function Containing Common Functionality
#'
#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
#' range is required
#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
#'
h_obtain_dose_grid_range <- function(object, ignore_placebo) {
  assert_flag(ignore_placebo)

  dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
    object@doseGrid[-1]
  } else {
    object@doseGrid
  }

  if (length(dose_grid) == 0L) {
    c(-Inf, Inf)
  } else {
    range(dose_grid)
  }
}

#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
#' Grade
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that takes a [`DataOrdinal`] object and an
#' integer grade and converts them to the equivalent `Data` object.
#'
#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Data`] object.
#'
#' @export
h_convert_ordinal_data <- function(data_ord, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(data_ord, "DataOrdinal")
  # Execute
  Data(
    ID = data_ord@ID,
    cohort = data_ord@cohort,
    x = data_ord@x,
    y = as.integer(data_ord@y >= grade),
    doseGrid = data_ord@doseGrid,
    nGrid = data_ord@nGrid,
    xLevel = data_ord@xLevel,
    placebo = data_ord@placebo
  )
}

#' @include helpers.R
#' @include helpers_covr.R
#' @include logger.R
#' @include Samples-class.R
NULL

# mcmc ----

#' Obtaining Posterior Samples for all Model Parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is the function that actually runs the `JAGS` MCMC machinery to produce
#' posterior samples from all model parameters and required derived values.
#' It is a generic function, so that customized versions may be conveniently
#' defined for specific subclasses of [`GeneralData`], [`GeneralModel`], and
#' [`McmcOptions`] input.
#'
#' @note The type of Random Number Generator (RNG) and its initial seed used by
#'   `JAGS` are taken from the `options` argument. If no initial values are
#'   supplied (i.e RNG kind or seed slot in `options` has `NA`), then they will
#'   be generated automatically by `JAGS`.
#'
#' @param data (`GeneralData`)\cr an input data.
#' @param model (`GeneralModel`)\cr an input model.
#' @param options (`McmcOptions`)\cr MCMC options.
#' @param ... not used.
#'
#' @return The posterior samples, an object of class [`Samples`].
#' @export
#'
setGeneric(
  name = "mcmc",
  def = function(data, model, options, ...) {
    standardGeneric("mcmc")
  },
  valueClass = "Samples"
)

# mcmc-GeneralData ----

#' @describeIn mcmc Standard method which uses JAGS.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData
#' @example examples/mcmc.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "GeneralModel",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    assert_flag(from_prior)

    model_fun <- if (from_prior) {
      model@priormodel
    } else {
      h_jags_join_models(model@datamodel, model@priormodel)
    }

    model_file <- h_jags_write_model(model_fun)
    model_inits <- h_jags_get_model_inits(model, data)
    model_data <- h_jags_get_data(model, data, from_prior)

    jags_model <- rjags::jags.model(
      file = model_file,
      data = model_data,
      inits = c(
        model_inits,
        .RNG.name = h_null_if_na(options@rng_kind),
        .RNG.seed = h_null_if_na(options@rng_seed)
      ),
      quiet = !is_logging_enabled(),
      n.adapt = 0 # No adaptation. Important for reproducibility.
    )
    update(jags_model, n.iter = options@burnin, progress.bar = "none")

    # This is necessary as some outputs are written directly from the JAGS
    # compiled code to the outstream.
    log_trace("Running rjags::jags.samples")
    if (is_logging_enabled()) {
      jags_samples <- rjags::jags.samples(
        model = jags_model,
        variable.names = model@sample,
        n.iter = (options@iterations - options@burnin),
        thin = options@step
      )
    } else {
      invisible(
        capture.output(
          jags_samples <- rjags::jags.samples(
            model = jags_model,
            variable.names = model@sample,
            n.iter = (options@iterations - options@burnin),
            thin = options@step,
            progress.bar = "none"
          )
        )
      )
    }
    log_trace("JAGS samples: ", jags_samples, capture = TRUE)
    samples <- lapply(jags_samples, h_jags_extract_samples)

    Samples(data = samples, options = options)
  }
)

# mcmc-GeneralData-DualEndpointRW ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointRW`] model, it is required that there are at least two (in
#'   case of random walk prior of the first order on the biomarker level) or
#'   three doses in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointRW
#' @example examples/mcmc-DualEndpointRW.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointRW",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    if (model@rw1) {
      assert_true(data@nGrid >= 2)
    } else {
      assert_true(data@nGrid >= 3)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointBeta ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointBeta`] model, it is required that the value of `ref_dose_beta`
#'   slot is greater than the maximum dose in a grid. This requirement comes from
#'   definition of the beta function that is used to model dose-biomarker
#'   relationship in [`DualEndpointBeta`] model. The other requirement is that
#'   there must be at least one dose in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointBeta
#' @example examples/mcmc-DualEndpointBeta.R
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointBeta",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    assert_true(data@nGrid >= 1)
    assert_true(model@ref_dose_beta > data@doseGrid[data@nGrid])

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-DualEndpointEmax ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`DualEndpointEmax`] model, it is required that there is at least one dose
#'   in the grid.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-DualEndpointEmax
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "DualEndpointEmax",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    assert_true(data@nGrid >= 1)

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParLogNormalPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParLogNormalPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParLogNormalPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParLogNormalPrior",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# mcmc-GeneralData-OneParExpPrior ----

#' @describeIn mcmc Standard method which uses JAGS. For the
#'   [`OneParExpPrior`] model, it is required that the length of
#'   skeleton prior probabilities vector should be equal to the length of the
#'   number of doses.
#'
#' @param from_prior (`flag`)\cr sample from the prior only? Default to `TRUE`
#'   when number of observations in `data` is `0`. For some models it might be
#'   necessary to specify it manually here though.
#'
#' @aliases mcmc-GeneralData-OneParExpPrior
#'
setMethod(
  f = "mcmc",
  signature = signature(
    data = "GeneralData",
    model = "OneParExpPrior",
    options = "McmcOptions"
  ),
  def = function(data,
                 model,
                 options,
                 from_prior = data@nObs == 0L,
                 ...) {
    if (!from_prior) {
      assert_true(length(model@skel_probs) == data@nGrid)
    }

    callNextMethod(
      data = data,
      model = model,
      options = options,
      from_prior = from_prior,
      ...
    )
  }
)

# nolint start

## --------------------------------------------------
## The method for DataMixture usage
## --------------------------------------------------

##' @describeIn mcmc Method for DataMixture with different from_prior default
setMethod("mcmc",
  signature =
    signature(
      data = "DataMixture",
      model = "GeneralModel",
      options = "McmcOptions"
    ),
  def =
    function(data, model, options,
             from_prior = data@nObs == 0L & data@nObsshare == 0L,
             ...) {
      callNextMethod(data, model, options, from_prior = from_prior, ...)
    }
)


## --------------------------------------------------
## Replacement for BayesLogit::logit
## --------------------------------------------------

#' Do MCMC sampling for Bayesian logistic regression model
#'
#' @param y 0/1 vector of responses
#' @param X design matrix
#' @param m0 prior mean vector
#' @param P0 precision matrix
#' @param options McmcOptions object
#'
#' @importFrom rjags jags.model jags.samples
#' @return the matrix of samples (samples x parameters)
#' @keywords internal
myBayesLogit <- function(y,
                         X,
                         m0,
                         P0,
                         options) {
  ## assertions
  p <- length(m0)
  nObs <- length(y)
  stopifnot(
    is.vector(y),
    all(y %in% c(0, 1)),
    is.matrix(P0),
    identical(dim(P0), c(p, p)),
    is.matrix(X),
    identical(dim(X), c(nObs, p)),
    is(options, "McmcOptions")
  )

  ## get or set the seed
  rSeed <- try(get(".Random.seed", envir = .GlobalEnv),
    silent = TRUE
  )
  if (is(rSeed, "try-error")) {
    set.seed(floor(runif(n = 1, min = 0, max = 1e4)))
    rSeed <- get(".Random.seed", envir = .GlobalEnv)
  }
  ## .Random.seed contains two leading integers where the second
  ## gives the position in the following 624 long vector (see
  ## ?set.seed). Take the current position and ensure positivity
  rSeed <- abs(rSeed[-c(1:2)][rSeed[2]])

  ## build the model according to whether we sample from prior
  ## or not:
  bugsModel <- function() {
    for (i in 1:nObs)
    {
      y[i] ~ dbern(p[i])
      logit(p[i]) <- mu[i]
    }

    mu <- X[, ] %*% beta

    ## the multivariate normal prior on the coefficients
    beta ~ dmnorm(priorMean[], priorPrec[, ])
  }

  ## write the model file into it
  modelFileName <- h_jags_write_model(bugsModel)

  jagsModel <- rjags::jags.model(modelFileName,
    data = list(
      "X" = X,
      "y" = y,
      "nObs" = nObs,
      priorMean = m0,
      priorPrec = P0
    ),
    quiet = TRUE,
    inits =
    ## add the RNG seed to the inits list:
    ## (use Mersenne Twister as per R
    ## default)
      list(
        .RNG.name = "base::Mersenne-Twister",
        .RNG.seed = rSeed
      ),
    n.chains = 1,
    n.adapt = 0
  )
  ## burn in
  update(jagsModel,
    n.iter = options@burnin,
    progress.bar = "none"
  )

  ## samples
  samplesCode <- "samples <-
    rjags::jags.samples(model=jagsModel,
                        variable.names='beta',
                        n.iter=
                          (options@iterations - options@burnin),
                        thin=options@step,
                        progress.bar='none')"

  ## this is necessary because some outputs
  ## are written directly from the JAGS compiled
  ## code to the outstream
  capture.output(eval(parse(text = samplesCode)))

  return(t(samples$beta[, , 1L]))
}


## ----------------------------------------------------------------------------------
## Obtain posterior samples for the two-parameter logistic pseudo DLE model
## -------------------------------------------------------------------------------


##' @describeIn mcmc Obtain posterior samples for the model parameters based on the pseudo 'LogisticsIndepBeta'
##' DLE model. The joint prior and posterior probability density function of
##' the intercept \eqn{\phi_1} (phi1) and the slope \eqn{\phi_2} (phi2) are given in Whitehead and
##' Williamson (1998) and TsuTakawa (1975). However, since asymptotically, the joint posterior probability density
##' will be bivariate normal and we will use the bivariate normal distribution to
##' generate posterior samples of the intercept and the slope parameters. For the prior samples of
##' of the intercept and the slope a bivariate normal distribution with mean and the covariance matrix given in Whitehead and
##' Williamson (1998) is used.
##'
##' @importFrom mvtnorm rmvnorm
##' @example examples/mcmc-LogisticIndepBeta.R
setMethod("mcmc",
  signature =
    signature(
      data = "Data",
      model = "LogisticIndepBeta",
      options = "McmcOptions"
    ),
  def =
    function(data, model, options,
             ...) {
      ## update the DLE model first
      thismodel <- update(object = model, data = data)

      ## decide whether we sample from the prior or not
      from_prior <- data@nObs == 0L


      ## probabilities of risk of DLE at all dose levels
      pi <- (thismodel@binDLE) / (thismodel@DLEweights)
      ## scalar term for the covariance matrix
      scalarI <- thismodel@DLEweights * pi * (1 - pi)
      ##
      precision <- matrix(rep(0, 4), nrow = 2, ncol = 2)

      for (i in (1:(length(thismodel@binDLE)))) {
        precisionmat <- scalarI[i] * matrix(c(1, log(thismodel@DLEdose[i]), log(thismodel@DLEdose[i]), (log(thismodel@DLEdose[i]))^2), 2, 2)
        precision <- precision + precisionmat
      }

      if (from_prior) {
        ## sample from the (asymptotic) bivariate normal prior for theta

        tmp <- mvtnorm::rmvnorm(
          n = size(options),
          mean = c(slot(thismodel, "phi1"), slot(thismodel, "phi2")),
          sigma = solve(precision)
        )


        samples <- list(
          phi1 = tmp[, 1],
          phi2 = tmp[, 2]
        )
      } else {
        weights <- rep(1, length(data@y))
        ## probabilities of risk of DLE at all dose levels
        pi <- (data@y) / weights
        ## scalar term for the covariance matrix
        scalarI <- weights * pi * (1 - pi)
        ##

        priordle <- thismodel@binDLE
        priorw1 <- thismodel@DLEweights

        priordose <- thismodel@DLEdose
        FitDLE <- suppressWarnings(glm(priordle / priorw1 ~ log(priordose), family = binomial(link = "logit"), weights = priorw1))
        SFitDLE <- summary(FitDLE)
        ## Obtain parameter estimates for dose-DLE curve
        priorphi1 <- coef(SFitDLE)[1, 1]
        priorphi2 <- coef(SFitDLE)[2, 1]

        ## use fast special sampler here
        ## set up design matrix
        X <- cbind(1, log(data@x))
        initRes <- myBayesLogit(
          y = data@y,
          X = X,
          m0 = c(priorphi1, priorphi2),
          P0 = precision,
          options = options
        )

        ## then form the samples list
        samples <- list(
          phi1 = initRes[, 1],
          phi2 = initRes[, 2]
        )
      }

      ## form a Samples object for return:
      ret <- Samples(
        data = samples,
        options = options
      )

      return(ret)
    }
)

## ================================================================================

## -----------------------------------------------------------------------------------
## obtain the posterior samples for the Pseudo Efficacy log log model
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the model parameters in the
##' Efficacy log log model. Given the value of \eqn{\nu}, the precision of the efficacy responses,
##' the joint prior or the posterior probability of the intercept \eqn{\theta_1} (theta1) and
##' the slope \eqn{\theta_2} (theta2) is a bivariate normal distribution. The  \eqn{\nu} (nu),
##' the precision of the efficacy responses is either a fixed value or has a gamma distribution.
##' If a gamma distribution is used, the samples of nu will be first generated.
##' Then the mean of the of the nu samples
##' will be used the generate samples of the intercept and slope parameters of the model
##' @example examples/mcmc-Effloglog.R
##' @importFrom mvtnorm rmvnorm
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataDual",
    model = "Effloglog",
    options = "McmcOptions"
  ),
  definition = function(data, model, options, ...) {
    model <- update(object = model, data = data)
    sample_size <- size(options)

    if (model@use_fixed) {
      nu <- model@nu
      nu_samples <- rep(nu, sample_size)
    } else {
      nu_samples <- rgamma(sample_size, shape = model@nu["a"], rate = model@nu["b"])
      nu <- mean(nu_samples)
    }

    # Sample from the (asymptotic) bivariate normal prior for theta1 and theta2.
    tmp <- mvtnorm::rmvnorm(
      n = sample_size,
      mean = model@mu,
      sigma = solve(nu * model@Q)
    )

    samples <- list(
      theta1 = tmp[, 1],
      theta2 = tmp[, 2],
      nu = nu_samples
    )

    Samples(
      data = samples,
      options = options
    )
  }
)
## ======================================================================================
## -----------------------------------------------------------------------------------
## obtain the posterior samples for the Pseudo Efficacy Flexible form
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the estimates in the Efficacy Flexible form.
##' This is the mcmc procedure based on what is described in Lang and Brezger (2004) such that
##' samples of the mean efficacy responses at all dose levels, samples of sigma2 \eqn{sigma^2},
##' the variance of the efficacy response and samples of sigma2betaW \eqn{sigma^2_{beta_W}}, the variance of
##' the random walk model will
##' be generated. Please refer to Lang and Brezger (2004) for the procedures and the form of
##' the joint prior and posterior probability density for the mean efficacy responses. In addition,
##' both sigma2 and sigma2betaW can be fixed or having an inverse-gamma prior and posterior distribution.
##' Therefore, if the inverse gamma distribution(s) are used, the parameters in the distribution will be
##' first updated and then samples of sigma2 and sigma2betaW will be generated using the updated parameters.
##' @example examples/mcmc-EffFlexi.R
setMethod("mcmc",
  signature =
    signature(
      data = "DataDual",
      model = "EffFlexi",
      options = "McmcOptions"
    ),
  def =
    function(data, model, options,
             ...) {
      ## update the model
      thismodel <- update(object = model, data = data)

      nSamples <- size(options)

      ## Prepare samples container
      ### List parameter samples to save
      samples <- list(
        ExpEff = matrix(ncol = data@nGrid, nrow = nSamples),
        sigma2W = matrix(nrow = nSamples),
        sigma2betaW = matrix(nrow = nSamples)
      )
      ## Prepare starting values
      ## Index of the next sample to be saved:

      iterSave <- 1L
      ## Monitoring the Metropolis-Hastings update for sigma2

      acceptHistory <- list(sigma2W = logical(options@iterations))

      ## Current parameter values and also the starting values for the MCMC are set
      ## EstEff: constant, the average of the observed efficacy values

      if (length(data@w) == 0) {
        w1 <- thismodel@eff
        x1 <- thismodel@eff_dose
      } else {
        ## Combine pseudo data with observed efficacy responses and no DLT observed
        eff_obsrv <- getEff(data, no_dlt = TRUE)
        w1 <- c(thismodel@eff, eff_obsrv$w_no_dlt)
        x1 <- c(thismodel@eff_dose, eff_obsrv$x_no_dlt)
      }
      x1Level <- match_within_tolerance(x1, data@doseGrid)
      ## betaW is constant, the average of the efficacy values
      betaW <- rep(mean(w1), data@nGrid)
      ## sigma2betaW use fixed value or prior mean
      sigma2betaW <-
        if (thismodel@use_fixed[["sigma2betaW"]]) {
          thismodel@sigma2betaW
        } else {
          thismodel@sigma2betaW["b"] / (thismodel@sigma2betaW["a"] - 1)
        }
      ## sigma2: fixed value or just the empirical variance
      sigma2W <- if (thismodel@use_fixed[["sigma2W"]]) {
        thismodel@sigma2W
      } else {
        var(w1)
      }
      ## Set up diagonal matrix with the number of patients in the corresponding dose levels on the diagonal
      designWcrossprod <- crossprod(thismodel@X)

      ### The MCMC cycle

      for (iterMcmc in seq_len(options@iterations))
      { ## 1) Generate coefficients for the Flexible Efficacy model
        ## the variance
        adjustedVar <- sigma2W
        ## New precision matrix
        thisPrecW <- designWcrossprod / adjustedVar + thismodel@RW / sigma2betaW
        ## draw random normal vector
        normVec <- rnorm(data@nGrid)
        ## and its Cholesky factor
        thisPrecWchol <- chol(thisPrecW)
        ## solve betaW for L^T * betaW = normVec
        betaW <- backsolve(r = thisPrecWchol, x = normVec)
        ## the residual
        adjustedW <- w1 - thismodel@X %*% betaW

        ## forward substitution
        ## solve L^T * tmp = designW ^T * adjustedW/ adjustedVar

        tmp <- forwardsolve(
          l = thisPrecWchol,
          x = crossprod(thismodel@X, adjustedW) / adjustedVar,
          upper.tri = TRUE,
          transpose = TRUE
        )
        ## Backward substitution solve R*tepNew =tmp
        tmp <- backsolve(
          r = thisPrecWchol,
          x = tmp
        )

        ## tmp is the mean vector of the distribution
        ## add tmp to betaW to obtain final sample

        betaW <- betaW + tmp

        ## 2) Generate prior variance factor for the random walk
        ## if fixed, do nothing
        ## Otherwise sample from full condition

        if (!thismodel@use_fixed[["sigma2betaW"]]) {
          sigma2betaW <- rinvGamma(
            n = 1L,
            a = thismodel@sigma2betaW["a"] + thismodel@RW_rank / 2,
            b = thismodel@sigma2betaW["b"] + crossprod(betaW, thismodel@RW %*% betaW) / 2
          )
        }
        ## 3) Generate variance for the flexible efficacy model
        ## if fixed variance is used
        if (thismodel@use_fixed[["sigma2W"]]) { ## do nothing
          acceptHistory$sigma2W[iterMcmc] <- TRUE
        } else {
          ## Metropolis-Hastings update step here, using
          ## an inverse gamma distribution
          aStar <- thismodel@sigma2W["a"] + length(x1) / 2
          ## Second parameter bStar depends on the value for sigma2W
          bStar <- function(x) {
            adjW <- w1
            ret <- sum((adjW - betaW[x1Level])^2) / 2 + thismodel@sigma2W["b"]
            return(ret)
          }
          ### Draw proposal:
          bStarProposal <- bStar(sigma2W)
          sigma2W <- rinvGamma(n = 1L, a = aStar, b = bStarProposal)
        }


        ## 4)Save Samples

        if (saveSample(options, iterMcmc)) {
          samples$ExpEff[iterSave, ] <- betaW
          samples$sigma2W[iterSave, 1] <- sigma2W
          samples$sigma2betaW[iterSave, 1] <- sigma2betaW
          iterSave <- iterSave + 1L
        }
      }


      ret <- Samples(
        data = samples,
        options = options
      )
      return(ret)
    }
)
# nolint end

## -----------------------------------------------------------------------------------
## obtain the posterior samples for ordinal models
## ----------------------------------------------------------------------------
##
##' @describeIn mcmc Obtain the posterior samples for the model parameters in the
##' `LogisticLogNormalOrdinal`.
##'
##' The generic `mcmc` method returns a `Samples` object with elements of the
##' `data` slot named `alpha[1]`, `alpha[2]`, ..., `alpha[k]` and `beta` when
##' passed a `LogisticLogNormalOrdinal` object.  This makes the "alpha elements"
##' awkward to access and is inconsistent with other `Model` objects.  So rename
##' the alpha elements to `alpha1`, `alpha2`, ..., `alpha<k>` for ease and
##' consistency.
##'
##' @example examples/mcmc-LogisticLogNormalOrdinal.R
setMethod(
  f = "mcmc",
  signature = signature(
    data = "DataOrdinal",
    model = "LogisticLogNormalOrdinal",
    options = "McmcOptions"
  ),
  definition = function(data, model, options, ...) {
    # Obtain samples using the default method, but ...
    return_value <- callNextMethod()
    # ... rename the alpha elements from alpha[<k>] to alpha<k>, where <k> is an
    # integer
    names(return_value@data) <- gsub("\\[(\\d+)\\]", "\\1", names(return_value@data))
    return_value
  }
)

# GeneralSimulations ----

#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`GeneralSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_general_simulations
#' @param object (`GeneralSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
#'   contains valid `data` object and valid `dose` simulations.

v_general_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    all(sapply(object@data, is, "Data")),
    "all data elements must be Data objects"
  )
  v$check(
    identical(length(object@doses), nSims),
    "doses must have same length as the data list"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`Simulations`] object
#'   contains valid object `fit`, `stop_reasons`, `stop_report`, and
#'   `additional_stats` compared to the general class [`GeneralSimulations`].
#'
v_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit), nSims),
    "fit must have same length as data"
  )
  v$check(
    identical(length(object@stop_reasons), nSims),
    "stop_reasons must have same length as data"
  )

  v$check(
    checkmate::test_matrix(object@stop_report,
      mode = "logical",
      nrows = nSims,
      min.cols = 1,
      any.missing = FALSE
    ),
    "stop_report must be a matrix of mode logical in which the number of rows
    equals the number of simulations and which must not contain any missing values"
  )

  v$result()
}

#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
#'
v_dual_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@fit_biomarker), nSims),
    "fit_biomarker list has to have same length as data"
  )
  v$check(
    identical(length(object@rho_est), nSims),
    "rho_est vector has to have same length as data"
  )
  v$check(
    identical(length(object@sigma2w_est), nSims),
    "sigma2w_est has to have same length as data"
  )

  v$result()
}

# PseudoSimulations ----

#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`PseudoSimulations`] or inherited classes and therefore not exported.
#'
#' @name v_pseudo_simulations
#' @param object (`PseudoSimulations`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
#'   contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
#'   `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
#'   `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
#'     object and valid `stopReasons` simulations.

v_pseudo_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)
  v$check(
    identical(length(object@stop_reasons), nSims),
    "stopReasons must have same length as data"
  )

  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
#'   contains valid `fitEff`, `FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
#'    `FinalGstarCIs` , `FinalGstarRatios`, `FinalOptimalDose`, `FinalOptimalDoseAtDoseGrid`
#'     object and valid `sigma2est` simulations.

v_pseudo_dual_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2est), nSims),
    "sigma2est has to have same length as data"
  )
  v$result()
}

#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
#' object contains valid `sigma2betaWest` vector of the final posterior mean
#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
#'
v_pseudo_dual_flex_simulations <- function(object) {
  v <- Validate()
  nSims <- length(object@data)
  v$check(
    identical(length(object@sigma2betaWest), nSims),
    "sigma2betaWest has to have same length as data"
  )
  v$result()
}

#' @describeIn v_general_simulations validates that the [`DASimulations`] object
#'   contains valid `trialduration` the vector of trial duration values for all
#'   simulations.

v_da_simulations <- function(object) {
  v <- Validate()

  nSims <- length(object@data)

  v$check(
    identical(length(object@trialduration), nSims),
    "trialduration vector has to have same length as data"
  )

  v$result()
}

#' Convenience function to make barplots of percentages
#'
#' @param x vector of samples
#' @param description xlab string
#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
#' be used)
#'
#' @return the ggplot2 object
#'
#' @keywords internal
#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
h_barplot_percentages <- function(x, description, xaxisround = 0) {
  assert_number(xaxisround, lower = 0)
  assert_character(description, len = 1, any.missing = FALSE)
  assert_numeric(x)

  tabx <- table(x) / length(x)
  dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
  ggplot() +
    geom_bar(aes(x = x, y = perc),
      data = dat,
      stat = "identity",
      position = "identity",
      width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
    ) +
    xlab(description) +
    ylab("Percent") +
    scale_x_continuous(
      breaks =
        round(dat$x, xaxisround)
    )
}



#' Helper function to calculate percentage of true stopping rules for
#' report label output
#' calculates true column means and converts output into percentages
#' before combining the output with the report label; output is passed
#' to [`show()`] and output with cat to console
#'
#' @param stop_report object from summary method
#' @return named list with label and percentage of rule activation


h_calc_report_label_percentage <- function(stop_report) {
  stop_pct <- colMeans(stop_report) * 100
  stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
  return(stop_pct_to_print)
}



#' Helper function to calculate average across iterations for each additional
#' reporting parameter
#' extracts parameter names as specified by user and averaged the values
#' for each specified parameter to [`show()`] and output with cat to console
#'
#' @param stats_list object from simulation with nested parameter values
#' (sublist for each parameter)
#' @return list of parameter names and averaged values for console output


h_summarize_add_stats <- function(stats_list) {
  # Extract the parameter names
  param_names <- names(stats_list[[1]])

  # Calculate the average for each parameter
  averages <- lapply(param_names, function(param) {
    values <- sapply(stats_list, function(x) x[[param]])
    mean(values)
  })

  return(list(param_names, averages))
}

#' Helper Function to Set and Save the RNG Seed
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This code is basically copied from `stats:::simulate.lm`.
#'
#' @param seed an object specifying if and how the random number generator
#' should be initialized ("seeded"). Either `NULL` (default) or an
#' integer that will be used in a call to [set.seed()] before
#' simulating the response vectors. If set, the value is saved as the
#' `seed` slot of the returned object. The default, `NULL` will
#' not change the random generator state.
#' @return The integer vector containing the random number generate state will
#' be returned, in order to call this function with this input to reproduce
#' the obtained simulation results.
#'
#' @export
set_seed <- function(seed = NULL) {
  assert_number(seed, null.ok = TRUE)

  if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
    runif(1)
  }

  if (is.null(seed)) {
    get(".Random.seed", envir = .GlobalEnv)
  } else {
    seed <- as.integer(seed)
    r_seed <- get(".Random.seed", envir = .GlobalEnv)
    # Make sure r_seed exists in parent frame.
    assign(".r_seed", r_seed, envir = parent.frame())
    set.seed(seed)
    # Here we need the r_seed in the parent.frame!
    do.call(
      "on.exit",
      list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
      envir = parent.frame()
    )
    structure(seed, kind = as.list(RNGkind()))
  }
}

#' Helper Function to Obtain Simulation Results List
#'
#' The function `fun` can use variables that are visible to itself.
#' The names of these variables have to be given in the vector `vars`.
#'
#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
#' single parameter the iteration index.
#' @param nsim number of simulations to be conducted.
#' @param vars names of the variables.
#' @param parallel should the simulation runs be parallelized across the
#' clusters of the computer?
#' @param n_cores how many cores should be used for parallel computing?
#' @return The list with all simulation results (one iteration corresponds
#' to one list element).
#'
#' @importFrom parallel makeCluster
#' @importFrom parallelly availableCores
#' @keywords internal programming
get_result_list <- function(
    fun,
    nsim,
    vars,
    parallel,
    n_cores) {
  assert_flag(parallel)
  assert_integerish(n_cores, lower = 1)

  if (!parallel) {
    lapply(
      X = seq_len(nsim),
      FUN = fun
    )
  } else {
    # Process all simulations.
    cores <- min(
      as.integer(n_cores),
      parallelly::availableCores()
    )

    # Start the cluster.
    cl <- parallel::makeCluster(cores)

    # Load the required R package.
    parallel::clusterEvalQ(cl, {
      library(crmPack)
      NULL
    })

    # Export local variables from the caller environment.
    # Note: parent.frame() is different from parent.env() which returns
    # the environment where this function has been defined!
    parallel::clusterExport(
      cl = cl,
      varlist = vars,
      envir = parent.frame()
    )

    # Export all global variables.
    parallel::clusterExport(
      cl = cl,
      varlist = ls(.GlobalEnv)
    )

    # Load user extensions from global options.
    crmpack_extensions <- getOption("crmpack_extensions")
    if (is.null(crmpack_extensions) != TRUE) {
      tryCatch(
        {
          parallel::clusterCall(cl, crmpack_extensions)
        },
        error = function(e) {
          stop("Failed to export crmpack_extensions: ", e$message)
        }
      )
    }

    # Do the computations in parallel.
    res <- parallel::parLapply(
      cl = cl,
      X = seq_len(nsim),
      fun = fun
    )

    # Stop the cluster.
    parallel::stopCluster(cl)

    res
  }
}




#' Helper Function to call truth calculation
#'
#' @param dose (`number`)\cr current dose.
#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
#' @param this_args (`data.frame`)\cr list of arguments for the truth.
#' @return The updated `this_truth`.
#'
#' @keywords internal
h_this_truth <- function(dose, this_args, truth) {
  do.call(
    truth,
    ## First argument: the dose
    c(
      dose,
      ## Following arguments
      this_args
    )
  )
}


#' Helper Function to create return list for Simulations output
#'
#' @param resultList (`list`)\cr raw iteration output.
#'
#' @return aggregated output for simulation object `list`.
#'
#' @keywords internal
h_simulations_output_format <- function(resultList) {
  ## put everything in the Simulations format:

  ## setup the list for the simulated data objects
  dataList <- lapply(resultList, "[[", "data")

  ## the vector of the final dose recommendations
  recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))

  ## setup the list for the final fits
  fitList <- lapply(resultList, "[[", "fit")

  ## the reasons for stopping
  stopReasons <- lapply(resultList, "[[", "stop")

  # individual stopping rule results as matrix, labels as column names
  stopResults <- lapply(resultList, "[[", "report_results")
  stop_matrix <- as.matrix(do.call(rbind, stopResults))

  # Result list of additional statistical summary.
  additional_stats <- lapply(resultList, "[[", "additional_stats")

  return(list(
    dataList = dataList,
    recommendedDoses = recommendedDoses,
    fitList = fitList,
    stopReasons = stopReasons,
    stopResults = stopResults,
    additional_stats = additional_stats,
    stop_matrix = stop_matrix
  ))
}


#' Helper function to recursively unpack stopping rules and return lists with
#' logical value and label given
#'
#' @param stopit_tree object from simulate method
#' @return named list

h_unpack_stopit <- function(stopit_tree) {
  label <- attr(stopit_tree, "report_label")
  value <- stopit_tree[1]
  names(value) <- label
  value
  if (is.null(attr(stopit_tree, "individual"))) {
    return(value)
  } else {
    return(unlist(c(value, lapply(attr(stopit_tree, "individual"), h_unpack_stopit))))
  }
}



#' Helper function to determine the dlts including first separate and placebo
#' condition
#'
#' @param data (`Data`)\cr what data to start from.
#' @param dose (`number`)\cr current dose.
#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
#' @param cohort_size (`number`)\cr the cohort size to use.
#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
#' @return updated data object
#' @keywords internal


h_determine_dlts <- function(data,
                             dose,
                             prob,
                             prob_placebo,
                             cohort_size,
                             cohort_size_placebo,
                             dose_grid,
                             first_separate) {
  assert_class(data, "Data")
  assert_number(dose)
  assert_number(prob)
  assert_number(cohort_size)
  assert_flag(first_separate)

  if (first_separate && cohort_size > 1) {
    dlts <- rbinom(n = 1, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
    }
    if (dlts == 0) {
      dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
      if ((data@placebo) && cohort_size_placebo > 0) {
        dlts_placebo <- c(dlts_placebo, rbinom(
          n = cohort_size_placebo, # cohort_size_placebo - 1?
          size = 1,
          prob = prob_placebo
        ))
      }
    }
  } else {
    dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
    if ((data@placebo) && cohort_size_placebo > 0) {
      dlts_placebo <- rbinom(n = cohort_size_placebo, size = 1, prob = prob_placebo)
    }
  }


  if ((data@placebo) && cohort_size_placebo > 0) {
    this_data <- update(
      object = data,
      x = dose_grid,
      y = dlts_placebo,
      check = FALSE
    )

    ## update the data with active dose
    this_data <- update(
      object = this_data,
      x = dose,
      y = dlts,
      new_cohort = FALSE
    )
  } else {
    ## update the data with this cohort
    this_data <- update(
      object = data,
      x = dose,
      y = dlts
    )
  }
  return(this_data)
}

# Integration with knitr ----
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional utility functions to allow human-friendly rendition of
#' crmPack objects in Markdown and Quarto files
#'
#' @return a character string that represents the object in markdown.
#' @name knit_print
NULL

# CohortSize ----

#' Render a `CohortSizeConst` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param x (`CohortSize`)\cr The object to knit_print.
#' @param asis (`flag`)\cr Should the return value be wrapped in a call to `knitr::asis_output`?
#' @param label (`character`)\cr The word used to label the participants.  See Usage Notes below.
#' @param ... Not used at present
#'
#' @section Usage Notes:
#' `label` describes the trial's participants.
#'
#' It should be a character vector of length 1 or 2.  If of length 2, the first
#' element describes a `cohort_size` of 1 and the second describes all other
#' `cohort_size`s.  If of length 1, the character `s` is appended to the value
#' when `cohort_size` is not 1.
#' @return The markdown representation of the object, as a character string
#' @seealso [`knit_print`] for more details.
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeConst <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
  assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)

  if (length(label) == 1) {
    label[2] <- paste0(label[1], "s")
  }
  rv <- paste0("A constant size of ", x@size, " ", label[ifelse(x@size == 1, 1, 2)], ".")
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeRange` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @param ... passed to `knitr::kable`
#' @inherit knit_print.CohortSizeConst return
#' @section Usage Notes:
#' The default value of `col.names` is `c("Lower", "Upper", "Cohort size")` and
#' that of `caption` is `"Defined by the dose to be used in the next cohort"`.
#' These values can be overridden by passing `col.names` and `caption` in the
#' function call.
#' @export
#' @rdname knit_print
knit_print.CohortSizeRange <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by the dose to be used in the next cohort"
  }
  x <- tidy(x)
  param[["x"]] <- x
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("Dose" = 2, " " = 1)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeDLT` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... Passed to [knitr::kable()].
#'
#' @section Usage Notes:
#' The by default, the columns are labelled `Lower`, `Upper` and `Cohort size`.  The table's caption is
#' `Defined by the number of DLTs so far observed`.  These values can be overridden by passing
#' `col.names` and `caption` in the function call.
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeDLT <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  param <- list(...)
  if (!("col.names" %in% names(param))) {
    param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
  }
  if (!("caption" %in% names(param))) {
    param[["caption"]] <- "Defined by the number of DLTs so far observed"
  }
  param[["x"]] <- tidy(x)
  rv <- kableExtra::add_header_above(
    do.call(knitr::kable, param),
    c("No of DLTs" = 2, " " = 1)
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeParts` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @inheritSection knit_print.CohortSizeConst Usage Notes
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeParts <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
  assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_flag(asis)

  if (length(label) == 1) {
    label[2] <- paste0(label[1], "s")
  }
  rv <- paste0(
    "A size of ",
    x@cohort_sizes[1],
    " ",
    label[ifelse(x@cohort_sizes[1] == 1, 1, 2)],
    " in the first part and ",
    x@cohort_sizes[2],
    " ",
    label[ifelse(x@cohort_sizes[2] == 1, 1, 2)],
    " in the second."
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeMax` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeMax <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- paste0(
    "The maximum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeMin` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` methods of the constituent
#' rules
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeMin <- function(x, ..., asis = TRUE) {
  assert_flag(asis)
  rv <- paste0(
    "The minimum of the cohort sizes defined in the following rules:",
    paste0(
      lapply(
        x@cohort_sizes,
        function(x, ...) {
          knit_print(x, asis = asis, ...)
        }
      ),
      collapse = "\n"
    ),
    paste = "\n"
  )
  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Render a `CohortSizeOrdinal` Object
#'
#' @description `r lifecycle::badge("experimental")`
#' @inherit knit_print.CohortSizeConst return
#' @param ... passed through to the `knit_print` method of the standard rule
#'
#' @export
#' @rdname knit_print
knit_print.CohortSizeOrdinal <- function(x, ..., asis = TRUE) {
  assert_flag(asis)

  rv <- paste0(
    "Based on a toxicity grade of ",
    x@grade,
    ": ",
    paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
    paste = "\n"
  )

  if (asis) {
    rv <- knitr::asis_output(rv)
  }
  rv
}

#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
#' from a Binary Model
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A simple helper function that converts a [`Samples`] object from the fit of an
#' ordinal CRM model to that which would have been obtained from fitting a binary
#' CRM model for toxicities of a specified grade to the same observed data.
#'
#' @param obj (`Samples`)\cr the `Samples` object to covert
#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
#' is required.
#' @return A [`Samples`] object.
#'
#' @export
h_convert_ordinal_samples <- function(obj, grade) {
  # Validate
  assert_integer(grade, len = 1, lower = 1)
  assert_class(obj, "Samples")
  assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
  # Execute
  d <- list("alpha0" = obj@data[[paste0("alpha", grade)]], "alpha1" = obj@data$beta)
  Samples(data = d, options = obj@options)
}

# assertions ----

#' Additional Assertions for `checkmate`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' We provide additional assertion functions that can be used together with
#' the `checkmate` functions. These are described in individual help pages
#' linked below.
#'
#' @return Depending on the function prefix.
#' - `assert_` functions return the object invisibly if successful, and otherwise
#'   throw an error message.
#' - `check_` functions return `TRUE` if successful, otherwise a string with the
#'   error message.
#' - `test_` functions just return `TRUE` or `FALSE`.
#'
#' @seealso [assert_probabilities()], [assert_probability()],
#'   [assert_probability_range()], [assert_length()].
#'
#' @name assertions
NULL

# check equality ----

#' Check if All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and returns `TRUE` if all
#' comparisons are equal within a given tolerance and `FALSE` otherwise.
#'
#' @param ... (`numeric`)\cr vectors to be compared.
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality.
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   returns `FALSE`, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
#'
#' @return `TRUE` if all element-by-element differences are less than `tolerance`
#' in magnitude, `FALSE` otherwise.
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_equal(1:2, 1:2) # TRUE
#' check_equal(1:2, 2:3) # "Not all equal"
#' check_equal(Inf, Inf) # "Not all equal"
#' check_equal(0.01, 0.02) # "Not all equal"
#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
#' check_equal(1, c(1, 1)) # "Not all equal"
check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
  dot_args <- list(...)

  sapply(dot_args, assert_numeric)

  tmp <- sapply(dot_args, length)
  if (min(tmp) != max(tmp)) {
    return("Not all of same length")
  }
  if (any(sapply(dot_args, is.na))) {
    return("Some entries NA")
  }
  if (any(sapply(dot_args, is.infinite))) {
    return("Not all entries finite")
  }
  if (!all(sapply(dot_args, test_numeric))) {
    return("Not all numeric")
  }

  all_ok <- test_true(
    all(
      sapply(
        2:length(dot_args),
        function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
      )
    )
  )
  if (all_ok) {
    return(TRUE)
  }
  "Not all equal"
}

#' Assert That All Arguments Are Equal
#'
#' @description `r lifecycle::badge("experimental")`
#' Elements of `...` must be numeric vectors or scalars.
#'
#' This function performs an element-by-element comparison of the first object
#' provided in `...` with every other object in `...` and throws an error if they
#' are not.
#'
#' @param ... (`numeric`)\cr vectors to be compared
#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
#' judging equality
#'
#' @note If there are any missing or infinite values in `...`, this function
#'   throws an error, regardless of the values of other elements in `...`.
#'
#' @note If elements in `...` are not all of the same length, an error is thrown.
#'
#' @return `list(...)`, invisibly.
#' @seealso [`assertions`] for more details.
#' @inheritParams checkmate::assert_numeric
#'
#' @export
#' @rdname check_equal
#' @examples
#' assert_equal(1:2, 1:2) # no error
#' assert_equal(0.01, 0.02, tol = 0.05) # no error
# nolint start
assert_equal <- function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) {
  # assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
  # in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
  # (add)", possibly because of the use of ... in check_equal.
  res <- check_equal(..., tol = tol)
  makeAssertion(list(...), res, .var.name, add)
}
# nolint end

# assert_probabilities ----

#' Check if an argument is a probability vector
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if every element in a given numerical vector or matrix represents a
#' probability, that is a number within (0, 1) interval, that can optionally be
#' closed at any side.
#'
#' @note If there are any missing or non-finite values in `x`, this function
#'   returns `FALSE`, regardless of the values of other elements in `x`.
#'
#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
#'   scalar or vector of length two. If it is a scalar, then its value applies
#'   equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
#'   with two flags, the first flag corresponds to the lower bound \eqn{0}
#'   only, and the second to the upper bound \eqn{1} only.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2, 0.1, 0.3, 1)
#' check_probabilities(x)
#' check_probabilities(x, bounds_closed = FALSE)
#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
check_probabilities <- function(x, bounds_closed = TRUE, len = NULL, unique = FALSE, sorted = FALSE) {
  assert_numeric(x)
  assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
  assert_number(len, null.ok = TRUE)
  assert_flag(sorted)

  result <- check_numeric(
    x,
    finite = TRUE, any.missing = FALSE, len = len, unique = unique, sorted = sorted
  )

  if (isTRUE(result)) {
    in_bounds <- all(h_in_range(x, range = c(0L, 1L), bounds_closed = bounds_closed))
    if (!in_bounds) {
      result <- paste(
        "Probability must be within",
        ifelse(bounds_closed[1], "[0,", "(0,"),
        ifelse(tail(bounds_closed, 1), "1]", "1)"),
        "bounds but it is not"
      )
    }
  }

  result
}

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
assert_probabilities <- makeAssertionFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
test_probabilities <- makeTestFunction(check_probabilities)

#' @rdname check_probabilities
#' @inheritParams check_probabilities
#' @export
expect_probabilities <- makeExpectationFunction(check_probabilities)

# assert_probability ----

#' Check if an argument is a single probability value
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given value represents a probability, that is a number within
#' (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr a single value to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_probability(0.5)
#' check_probability(0, bounds_closed = FALSE)
#' check_probability(0, bounds_closed = c(FALSE, TRUE))
check_probability <- function(x, bounds_closed = TRUE) {
  check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
}

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
assert_probability <- makeAssertionFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
test_probability <- makeTestFunction(check_probability)

#' @rdname check_probability
#' @inheritParams check_probability
#' @export
expect_probability <- makeExpectationFunction(check_probability)

# assert_probability_range ----

#' Check if an argument is a probability range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Check if a given numerical interval represents a probability range, that is
#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
#'
#' @param x (`number`)\cr an interval to check.
#' @inheritParams check_probabilities
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' x <- c(0, 0.2)
#' check_probability_range(x)
#' check_probability_range(rev(x))
#' check_probability_range(x, bounds_closed = FALSE)
#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
check_probability_range <- function(x, bounds_closed = TRUE) {
  check_probabilities(x = x, bounds_closed = bounds_closed, len = 2, sorted = TRUE)
}

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
assert_probability_range <- makeAssertionFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
test_probability_range <- makeTestFunction(check_probability_range)

#' @rdname check_probability_range
#' @inheritParams check_probability_range
#' @export
expect_probability_range <- makeExpectationFunction(check_probability_range)

# assert_length ----

#' Check if vectors are of compatible lengths
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Two vectors are of compatible size if and only if: \cr
#' 1. At least one vector has size 1 \cr
#' 2. or both vectors are of the same size. \cr
#'
#' @param x (`any`)\cr the first vector, any object for which [length()]
#'   function is defined.
#' @param len (`count`)\cr the length of the second vector.
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_length(1:5, 1)
#' check_length(1:5, 6)
#' check_length(1:5, 5)
#' check_length(10, 1)
#' check_length(10, 9)
check_length <- function(x, len) {
  x_len <- length(x)
  assert_true(x_len >= 1L)
  assert_count(len)

  if (x_len == 1L || len == 1L || x_len == len) {
    TRUE
  } else {
    paste(
      "x is of length",
      x_len,
      "which is not allowed; the allowed lengths are: 1 or",
      len,
      collapse = ""
    )
  }
}

#' @rdname check_length
#' @inheritParams check_length
#' @export
assert_length <- makeAssertionFunction(check_length)

#' @rdname check_length
#' @inheritParams check_length
#' @export
test_length <- makeTestFunction(check_length)

# assert_range ----

#' Check that an argument is a numerical range
#'
#' @description `r lifecycle::badge("stable")`
#'
#' An argument `x` is a numerical range if and only if (all conditions must be met):
#' 1. Is an object of type: `integer` or `double`.
#' 2. Is a vector or length two such that the value of the first number is not
#' less than the second number. Equalness is allowed if and only if `unique` flag
#' is set to `TRUE`.
#' 3. Lower bound of the interval is greater than or equal to `lower` and
#' upper bound of the interval is less than or equal to `upper`.
#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
#'
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_range(c(1, 5))
#' check_range(c(-5, 1))
#' check_range(c(4, 1))
#' check_range(c(1, 1))
#' check_range(c(1, 1), unique = FALSE)
#' check_range(1:3)
check_range <- function(x, lower = -Inf, upper = Inf, finite = FALSE, unique = TRUE) {
  assert_number(lower)
  assert_number(upper)
  assert_flag(finite)
  assert_flag(unique)

  result <- check_numeric(
    x,
    lower = lower,
    upper = upper,
    finite = finite,
    any.missing = FALSE,
    len = 2,
    unique = unique,
    sorted = TRUE
  )

  if (!isTRUE(result)) {
    result <- paste("x must be a valid numerical range.", result)
  }
  result
}

#' @rdname check_range
#' @inheritParams check_range
#' @export
assert_range <- makeAssertionFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
test_range <- makeTestFunction(check_range)

#' @rdname check_range
#' @inheritParams check_range
#' @export
expect_range <- makeExpectationFunction(check_range)

# assert_format ----

#' Check that an argument is a valid format specification
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams checkmate::check_numeric
#'
#' @return `TRUE` if successful, otherwise a string with the error message.
#'
#' @seealso [`assertions`] for more details.
#'
#' @export
#' @examples
#' check_format("%5.2f")
check_format <- function(x, len = NULL, min.len = NULL, max.len = NULL) {
  assert_number(len, lower = 1, null.ok = TRUE)
  assert_number(min.len, lower = 1, null.ok = TRUE)
  assert_number(max.len, lower = 1, null.ok = TRUE)

  result <- check_character(
    x,
    len = len,
    min.len = min.len,
    max.len = max.len,
    any.missing = FALSE,
    # https://stackoverflow.com/questions/446285/validate-sprintf-format-from-input-field-with-regex
    pattern = "%(?:\\d+\\$)?[+-]?(?:[ 0]|'.{1})?-?\\d*(?:\\.\\d+)?[bcdeEufFgGosxX]",
  )

  if (!isTRUE(result)) {
    result <- paste("x must be a valid format specifier.", result)
  }
  result
}

#' @rdname check_format
#' @inheritParams check_format
#' @export
assert_format <- makeAssertionFunction(check_format)

#' @rdname check_format
#' @inheritParams check_format
#' @export
test_format <- makeTestFunction(check_format)

#' @rdname check_format
#' @inheritParams check_format
#' @export
expect_format <- makeExpectationFunction(check_format)

# v_mcmc_options ----

#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These functions are only used internally to validate the format of an input
#' [`McmcOptions`] or inherited classes and therefore not exported.
#'
#' @name v_mcmcoptions_objects
#' @param object (`McmcOptions`)\cr object to validate.
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
#'   object contains valid integer scalars `iterations`, `burnin` and `step`
#'   as well as proper parameters for Random Number Generator.
v_mcmc_options <- function(object) {
  v <- Validate()
  allowed_rng_kinds <- c(
    "base::Wichmann-Hill",
    "base::Marsaglia-Multicarry",
    "base::Super-Duper",
    "base::Mersenne-Twister",
    NA_character_
  )

  v$check(
    test_int(object@iterations, lower = 1L),
    "iterations must be integer scalar greater than or equal to 1"
  )
  v$check(
    test_int(object@burnin, lower = 0L),
    "burn-in must be non-negative integer scalar"
  )
  # This below check should not be conducted in above test, using
  # `upper = object@iterations -1` argument, since object@iterations might be
  # not-valid. In such a case `test_int` throws an internal error.
  v$check(
    test_true(object@burnin < object@iterations),
    "burn-in must be lower than iterations"
  )
  v$check(
    test_int(object@step, lower = 1L),
    "step must be integer scalar greater than or equal to 1"
  )

  is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
  v$check(is_rng_kind_scalar, "rng_kind must be a single string")
  v$check(
    test_subset(object@rng_kind, allowed_rng_kinds),
    paste0(
      "rng_kind must one of the following: ",
      paste(allowed_rng_kinds, collapse = ", "),
      ". User specifies the rng_kind without `base::` prefix"
    )
  )

  is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
  v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")

  # Below `if` condition is not only reasonable but also needed as R CMD check
  # is activating some stricter checks and it fails when arguments to `||` are
  # not scalars, even if `||` works well with vectors of length > 1.
  if (is_rng_kind_scalar && is_rng_seed_scalar) {
    v$check(
      !is.na(object@rng_kind) || is.na(object@rng_seed),
      "rng_seed supplied but rng_kind not set"
    )
  }
  v$result()
}

# tidy ----

## generic ----

#' Tidying `CrmPackClass` objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' In the spirit of the `broom` package, provide a method to convert a
#' `CrmPackClass` object to a (list of) tibbles.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods
#'
#' @return A (list of) tibble(s) representing the object in tidy form.
#'
#' @export
#'
setGeneric(
  name = "tidy",
  def = function(x, ...) {
    standardGeneric("tidy")
  }
)

## CrmPackClass ----

#' Tidy a `CrmPackClass` Object
#'
#' Following the principles of the `broom` package, convert a `CrmPackClass`
#' object to a (list of) tibbles.  This is a basic, default representation.
#'
#' @param x (`CrmPackClass`)\cr the object to be tidied.
#' @param ... potentially used by class-specific methods.
#' @rdname tidy
#' @aliases tidy-CrmPackClass
#' @keywords methods
#' @example examples/CrmPackClass-method-tidy.R
#'
#' @export
setMethod(
  f = "tidy",
  signature = signature(x = "CrmPackClass"),
  definition = function(x, ...) {
    rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
    if (length(rv) == 1) {
      rv[[names(rv)[1]]] %>% h_tidy_class(x)
    } else {
      rv
    }
  }
)

#' Verbose Logging
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' A family of wrappers of selected [`futile.logger`] functions that control
#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
#' package for the logging purposes. All the messages logged in `crmPack` are
#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
#' enabling verbose logging means that the logging threshold will be set to
#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
#' logging means that it will be set to [`futile.logger::FATAL`].
#'
#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
#'   setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
#'
#' @export
#'
enable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
#'   by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
#'   logger.
#'
#' @export
#'
disable_logging <- function() {
  invisible(
    futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
  )
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.logger()] that checks whether current threshold level
#'   for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
#'   It returns `TRUE` if the current logging level is verbose, `FALSE`
#'   otherwise.
#'
#' @export
#'
is_logging_enabled <- function() {
  logger <- futile.logger::flog.logger(name = "crmPack")
  unname(logger$threshold == futile.logger::TRACE)
}

#' @describeIn enable_logging A simple wrapper of
#'   [futile.logger::flog.trace()] that prints a log message in the `crmPack`
#'   logger.
#'
#' @inheritParams futile.logger::flog.trace
#'
#' @export
#'
log_trace <- function(msg, ..., capture = FALSE) {
  assert_string(msg)
  assert_flag(capture)

  futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
}

#' Internal Helper Functions for Validation of Model Parameters Objects
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' These functions are only used internally to validate the format of an object
#' with model parameters or inherited classes and therefore not exported.
#'
#' @name v_model_params
#' @return A `character` vector with the validation failure messages,
#'   or `TRUE` in case validation passes.
NULL

#' @describeIn v_model_params a helper function that validates multivariate normal
#'   parameters.
#' @param object (`ModelParamsNormal`)\cr multivariate normal parameters object
#'   to validate.
v_model_params_normal <- function(object) {
  v <- Validate()

  v$check(
    test_numeric(x = object@mean, min.len = 2L, any.missing = FALSE),
    "mean must have length of at least 2 and no missing values are allowed"
  )
  is_cov_valid <- h_is_positive_definite(object@cov, length(object@mean))
  v$check(
    is_cov_valid,
    "cov must be positive-definite matrix without any missing values"
  )
  is_prec_valid <- h_is_positive_definite(object@prec, length(object@mean))
  v$check(
    is_prec_valid,
    "prec must be positive-definite matrix without any missing values"
  )
  if (is_cov_valid && is_prec_valid) {
    v$check(
      all.equal(object@cov %*% object@prec, diag(1, length(object@mean)), check.attributes = FALSE) == TRUE,
      "prec must be inverse of cov"
    )
  }
  v$result()
}

#' @include McmcOptions-class.R
NULL

# size ----

## generic ----

#' Size of an Object
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that computes the size of a given object. This can be for instance
#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
#' method for more details.
#'
#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
#'   for which the size is computed.
#' @param ... further arguments passed to `size` specific methods.
#'
#' @return A size of a given object.
#' @export
#'
setGeneric(
  name = "size",
  def = function(object, ...) {
    standardGeneric("size")
  },
  valueClass = "integer"
)

## McmcOptions ----

#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
#'   object.
#' @aliases size-McmcOptions
#' @example examples/McmcOptions-methods-size.R
setMethod(
  f = "size",
  signature = signature(object = "McmcOptions"),
  definition = function(object, ...) {
    iterations_relative <- object@iterations - object@burnin
    if (iterations_relative <= 0) {
      return(0L)
    }
    as.integer(floor(iterations_relative / object@step))
  }
)

# saveSample ----

## generic ----

#' Determining if this Sample Should be Saved
#'
#' @description `r lifecycle::badge("stable")`
#'
#' A method that determines if a sample from a given `iteration` should be
#' saved. The sample should be saved if and only if:
#' it is not in burn-in period and it matches the `step`.
#'
#' @param object (`McmcOptions`)\cr object based on which the answer is
#'   determined.
#' @param iteration (`count`)\cr the current iteration index.
#' @param ... not used.
#' @return `TRUE` if this sample should be saved.
#' @export
#'
setGeneric(
  name = "saveSample",
  def = function(object, iteration, ...) {
    standardGeneric("saveSample")
  },
  valueClass = "logical"
)

## McmcOptions ----

#' @describeIn saveSample determine if a sample should be saved.
#' @aliases saveSample-McmcOptions
#' @example examples/McmcOptions-methods-saveSample.R
setMethod(
  f = "saveSample",
  signature = signature(object = "McmcOptions"),
  definition = function(object, iteration, ...) {
    iteration_relative <- iteration - object@burnin
    iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
  }
)

#' Helpers for stripping expressions of `covr`-inserted trace code
#'
#' Workarounds to allow the package to continue to work while running `covr`
#' with minimal changes to the package code.
#'
#' @details
#' When using `covr`, the source code for package objects are modified to add
#' callbacks for each expression to log its execution. Given an arbitrary
#' expression, such as:
#'
#'     expr
#'
#' The code will be modified before executing any package code to look like:
#'
#'     if (TRUE) {
#'       covr:::count("file.R:1:2:3:4:5:6:7:8")
#'       expr
#'     }
#'
#' These functions are used for stripping expressions of this code so that the
#' package continues to work as intended while running tests as part of running
#' `covr` to calculate package coverage.
#'
#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
#' behaviors necessary for this package.
#'
#' @param expr (`language`)\cr an R expression or call to test or strip of
#'   `covr` trace counters.
#'
#' @return A logical value or transformed expression with calls to
#'   `covr:::count` removed.
#'
#' @name h_covr_helpers
#' @keywords internal
#'
NULL

#' @describeIn h_covr_helpers
#' Determine whether `covr` is currently running
h_covr_active <- function() {
  identical(Sys.getenv("R_COVR"), "true")
}

#' @describeIn h_covr_helpers
#' Remove `covr` traces from an expression
h_covr_detrace <- function(expr) {
  if (!h_covr_active()) {
    return(expr)
  }

  if (is.function(expr)) {
    body(expr) <- h_covr_detrace(body(expr))
    return(expr)
  }

  detrace <- function(x) {
    # returns "missing" expression to avoid errors with calls
    if (identical(x, bquote())) {
      return(x)
    }

    x <- h_covr_detrace_call(x)
    if (is.call(x)) x[-1] <- lapply(x[-1], h_covr_detrace)
    x
  }

  detrace(expr)
}

#' @describeIn h_covr_helpers
#' Determine whether the current expression is a `covr`-modified expression
h_is_covr_trace <- function(expr) {
  # Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
  is.call(expr) &&
    expr[[1]] == "if" &&
    expr[[2]] == quote(TRUE) &&
    expr[[3]][[1]] == "{" &&
    length(expr[[3]] >= 3) &&
    is.call(expr[[3]][[2]]) &&
    expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
}

#' @describeIn h_covr_helpers
#' Extract the original expression from a `covr`-modified expression
h_covr_detrace_call <- function(expr) {
  if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
}

#' @include helpers.R
#' @include McmcOptions-validity.R
#' @include CrmPackClass-class.R
NULL

# McmcOptions ----

## class ----

#' `McmcOptions`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
#' Random Number Generator settings.
#'
#' @slot iterations (`count`)\cr number of MCMC iterations.
#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @slot step (`count`)\cr only every `step`-th iteration is saved after
#'   the `burnin`. In other words, a sample from iteration
#'   `i = 1,...,iterations`, is saved if and only if
#'   `(i - burnin) mod step = 0`.\cr
#'   For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
#'   samples from iterations `2,4,6` will be saved.
#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
#'   [`rjags`]. It must be one out of the following four values:
#'   `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
#'   `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
#'   If it is `NA_character_` (default), then the RNG kind will be chosen by
#'   [`rjags`].
#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
#'   used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
#'   `NA_integer_`, which means that the seed will be chosen by [`rjags`].
#'
#' @aliases McmcOptions
#' @export
#'
.McmcOptions <- setClass(
  Class = "McmcOptions",
  slots = c(
    iterations = "integer",
    burnin = "integer",
    step = "integer",
    rng_kind = "character",
    rng_seed = "integer"
  ),
  prototype = prototype(
    iterations = 1000L,
    burnin = 100L,
    step = 2L,
    rng_kind = NA_character_,
    rng_seed = NA_integer_
  ),
  contains = "CrmPackClass",
  validity = v_mcmc_options
)

## constructor ----

#' @rdname McmcOptions-class
#'
#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
#' @param step (`count`)\cr only every step-th iteration is saved after
#'   the burn-in.
#' @param samples (`count`)\cr number of resulting samples.
#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
#'   `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
#'   If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
#'   It must be an integer value or `NA` (default), which means that the seed
#'   will be chosen by `[rjags`].
#'
#' @export
#' @example examples/McmcOptions-class-McmcOptions.R
#'
McmcOptions <- function(burnin = 1e4L,
                        step = 2L,
                        samples = 1e4L,
                        rng_kind = NA_character_,
                        rng_seed = NA_integer_) {
  assert_count(burnin, positive = TRUE)
  assert_count(step, positive = TRUE)
  assert_count(samples, positive = TRUE)
  assert_string(rng_kind, na.ok = TRUE)
  assert_count(rng_seed, na.ok = TRUE)

  if (!is.na(rng_kind)) {
    rng_kind <- paste0("base::", rng_kind)
  } else {
    rng_kind <- NA_character_
  }
  if (!is.na(rng_seed)) {
    rng_seed <- as.integer(rng_seed)
  } else {
    rng_seed <- NA_integer_
  }

  .McmcOptions(
    iterations = as.integer(burnin + (step * samples)),
    burnin = as.integer(burnin),
    step = as.integer(step),
    rng_kind = rng_kind,
    rng_seed = as.integer(rng_seed)
  )
}

## default constructor ----

#' @rdname McmcOptions-class
#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
#' @export
.DefaultMcmcOptions <- function() {
  McmcOptions(
    burnin = 250,
    samples = 1000
  )
}

# nolint start

#####################################################################################
## Author: Daniel Sabanes Bove [sabanesd *a*t* roche *.* com]
## Project: Object-oriented implementation of CRM designs
##
## Time-stamp: <[crmPack-package.R] by DSB Mon 11/05/2015 17:47>
##
## Description:
## Package description.
##
## History:
## 29/01/2014   file creation
#####################################################################################

#' Object-oriented implementation of CRM designs
#'
#' @name crmPack-package
#' @aliases crmPack
#' @docType package
#' @title Object-oriented implementation of CRM designs
#' @import checkmate
#' @import ggplot2
#' @import methods
#' @import tibble
#' @importFrom grid grid.draw
#' @importFrom gridExtra arrangeGrob
#' @importFrom graphics plot hist legend lines matlines matplot
#' @importFrom stats binomial coef cov2cor gaussian glm lm median model.matrix
#'   optim pgamma plogis pnorm qgamma qlogis qnorm quantile rbinom rgamma
#'   approxfun rnorm runif uniroot var vcov step mad pbeta dbeta dgamma
#'   setNames
#' @importFrom utils data head tail capture.output
#' @importFrom lifecycle badge
#' @importFrom rjags jags.model jags.samples
#' @importFrom futile.logger flog.threshold flog.logger flog.trace TRACE FATAL
#' @importFrom knitr knit_print
#' @importFrom kableExtra kbl add_header_above column_spec collapse_rows
#'   kable_styling add_footnote kable
#'
#' @keywords package
#' @references Sabanes Bove D, Yeung WY, Palermo G, Jaki T (2019).
#' "Model-Based Dose Escalation Designs in R with crmPack."
#' Journal of Statistical Software, 89(10), 1-22.
#' doi:10.18637/jss.v089.i10 (URL: http://doi.org/10.18637/jss.v089.i10).
{}

##' @keywords internal
.onAttach <- function(libname, pkgname) {
  packageStartupMessage(
    "Type crmPackHelp() to open help browser\n",
    "Type crmPackExample() to open example\n"
  )
}

## need to declare global variable / function
## names in order to avoid R CMD check notes:
globalVariables(c(
  "log.betaZ",
  "precW",
  "pow",
  "nObs",
  "betaZ",
  "x",
  "betaW",
  "xLevel",
  "precW",
  "z",
  "nGrid",
  "doseGrid",
  "betaWintercept",
  "delta",
  "deltaStart",
  "delta2",
  "Effsamples",
  "logit<-",
  "rho0",
  "alpha0",
  "delta0",
  "alpha1",
  "delta1",
  "inverse",
  "priorCov",
  "theta",
  "comp0",
  "w",
  "DLTs",
  "y",
  "group",
  "annotate",
  "probSamples",
  "prec",
  "nu",
  "samples",
  "Type",
  "patient",
  "toxicity",
  "ID",
  "biomarker",
  "traj",
  "Statistic",
  "perc",
  "..density..",
  "middle",
  "lower",
  "upper",
  "middleBiomarker",
  "lowerBiomarker",
  "upperBiomarker",
  "nObsshare",
  "xshare",
  "yshare",
  "thisProb.PL",
  "thisMeanEff.PL",
  "thisSize.PL",
  "probit<-",
  "refDose",
  "Tmax",
  "u",
  "eps",
  "h",
  "lambda",
  "cadj",
  "A",
  "lambda_p",
  "cond",
  "t0",
  "tend",
  "t0_case",
  "tend_case",
  "yhat",
  "ref_dose",
  "comp",
  "X",
  "skel_probs",
  "is_combo",
  "results",
  "k",
  "value",
  "Parameter",
  "intervals",
  "Group",
  "Tox"
))

# nolint end

#' Apply a Function to Subsets of Data Frame.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' `dapply` splits the data `df` into the subsets defined by `f`,
#' and applies function `FUN` to each of the subset.
#' All the results are row-binded and returned as `data.frame` object.
#'
#' @param df (`data frame`)\cr data set to be divided into groups.
#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
#'   `as.factor(f)` defines the grouping, or a `list` of such factors in which
#'   case their interaction is used for the grouping. `f` can also be a formula
#'   of the form `~ g1 + ... + gk` to split by the interaction of the variables
#'   `g1, ..., gk`. This parameter is passed directly into [split()] function.
#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
#'   defined by `f`.
#' @param ... parameters passed to [lapply()], which is used when applying a
#'   function `FUN` over groups defined by `f`.
#'
#' @return The [`data.frame`] object with results from `FUN`.
#'
#' @export
#' @example examples/utils-dapply.R
#'
dapply <- function(df, f, FUN, ...) {
  assert_data_frame(df)

  list_df <- split(df, f = f)
  list_df <- lapply(list_df, FUN, ...)
  df2 <- do.call(rbind, list_df)
  rownames(df2) <- NULL
  df2
}

#' @include McmcOptions-methods.R
NULL

# v_samples ----

#' Internal Helper Functions for Validation of [`Samples`] Objects
#'
#' @description These functions are only used internally to validate the format
#'   of an input [`Samples`] or inherited classes and therefore not exported.
#'
#' @name v_samples_objects
#' @param object (`Samples`)\cr object to validate.
#' @return A `character` vector with the validation failure messages, or `TRUE`
#'   in case validation passes.
NULL

#' @describeIn v_samples_objects validates that the [`Samples`] object contains
#'   valid `data` slot.
v_samples <- function(object) {
  v <- Validate()
  v$check(
    all(sapply(object@data, NROW) == size(object@options)),
    "Every element in data must be of the same length (no. of rows) as the sample size was"
  )
  v$check(
    all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
    "Every element in data must be a finite object of type integer or double"
  )
  v$result()
}

#' @include McmcOptions-class.R
#' @include Samples-validity.R
#' @include CrmPackClass-class.R
NULL

# Samples ----

## class ----

#' `Samples`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' [`Samples`] is the class to store the MCMC samples.
#'
#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
#'   must be a vector (in case of a scalar parameter) or matrix (in case of a
#'   vector-valued parameter) with samples.
#'   In case of matrix, every row is a separate sample, while columns correspond
#'   to the dimension of the parameter.
#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
#'   samples.
#'
#' @aliases Samples
#' @export
#'
.Samples <- setClass(
  Class = "Samples",
  slots = c(
    data = "list",
    options = "McmcOptions"
  ),
  prototype = prototype(
    data = list(),
    options = McmcOptions()
  ),
  contains = "CrmPackClass",
  validity = v_samples
)

## constructor ----

#' @rdname Samples-class
#'
#' @param data see slot definition.
#' @param options see slot definition.
#'
#' @export
#' @example examples/Samples-class.R
#'
Samples <- function(data, options) {
  new("Samples", data = data, options = options)
}

## default constructor ----

#' @rdname Samples-class
#' @note Typically, end users will not use the `.DefaultSamples()` function.
#' @export
.DefaultSamples <- function() {
  mcmc(
    data = .DefaultData(),
    model = .DefaultLogisticLogNormal(),
    options = .DefaultMcmcOptions()
  )
}

#' @include helpers.R
#' @include ModelParams-validity.R
#' @include CrmPackClass-class.R
NULL

# ModelParamsNormal ----

## class ----

#' `ModelParamsNormal`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
#' i.e. the mean vector, covariance matrix and precision matrix.
#' The precision matrix is an inverse of the covariance matrix in the
#' `JAGS` and it is computed internally by the object constructor function.
#'
#' @slot mean (`numeric`)\cr the mean vector.
#' @slot cov (`matrix`)\cr the covariance matrix.
#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
#'
#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
#'
#' @aliases ModelParamsNormal
#' @export
#'
.ModelParamsNormal <- setClass(
  Class = "ModelParamsNormal",
  slots = c(
    mean = "numeric",
    cov = "matrix",
    prec = "matrix"
  ),
  contains = "CrmPackClass",
  validity = v_model_params_normal
)

## constructor ----

#' @rdname ModelParamsNormal-class
#'
#' @param mean (`numeric`)\cr the prior mean vector.
#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
#'   `prec` is internally calculated as an inverse of `cov`.
#'
#' @export
#' @examples
#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
ModelParamsNormal <- function(mean, cov) {
  assert_matrix(
    cov,
    mode = "numeric",
    any.missing = FALSE,
    nrows = length(mean),
    ncols = length(mean)
  )
  # To ensure that `cov` is invertible:
  assert_true(h_is_positive_definite(cov, length(mean)))

  .ModelParamsNormal(
    mean = mean,
    cov = cov,
    prec = solve(cov)
  )
}

## default constructor ----

#' @rdname ModelParamsNormal-class
#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
#' @export
.DefaultModelParamsNormal <- function() {
  ModelParamsNormal(
    mean = c(1, 0),
    cov = matrix(c(1, 0, 0, 1), nrow = 2)
  )
}

1		#' Convert Object's Attributes to a Tibble
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A helper function that interrogates an object to see if it has attributes
6		#' and, if so, converts them to a (list of) tibbles. Columns are named after
7		#' attributes. If attributes have different lengths but recycling is possible,
8		#' a single `tibble` is returned. Otherwise, a `list` of tibbles is returned.
9		#'
10		#' @param x (`CrmPackObject`)\cr object whose attributes will be interrogated.
11		#' @param .ignore (`character`)\cr names of attrributes to be ignored.
12		#'
13		#' @return A [`tibble`] or `list` of [`tibble`]s containg the values of the
14		#' object's attributes.
15		#'
16		#' @keywords internal
17		#' @noRd
18		h_handle_attributes <- function(x, .ignore = c("names", "class", "description", "row.names")) {
19	3x	a <- attributes(x)
20	3x	valid_names <- setdiff(names(a), .ignore)
21	3x	lapply(
22	3x	valid_names,
23	3x	function(n) {
24	18x	z <- attr(x, n)
25	18x	rv <- NULL
26		# Some Design classes have attributes that are functions or CrmPackClass objects
27	18x	if (!is.function(z)) {
28	18x	if (length(z) == 1) {
29	18x	if (is(z, "CrmPackClass")) {
30	!	z <- z %>% tidy()
31		}
32	18x	rv <- tibble::tibble(X = z)
33		} else {
34	!	if (length(z) == 0) {
35	!	rv <- tibble::tibble(X = NA)
36		} else {
37	!	if (is(z, "CrmPackClass")) {
38	!	rv <- z %>% tidy()
39		} else {
40	!	rv <- tibble::tibble(X = list(z))
41		}
42		}
43		}
44	18x	names(rv) <- n
45		}
46	18x	rv
47		}
48		) %>%
49	3x	dplyr::bind_cols()
50		}
51
52		#' Tidy a Single Slot of a CrmPackObject
53		#'
54		#' @description `r lifecycle::badge("experimental")`
55		#'
56		#' A helper function that converts a single slot of a `CrmPackObject` to a tibble.
57		#' If the slots value is a `list`, each element of the list is tidied individually.
58		#'
59		#' @param obj (`CrmPackObject`)\cr object to be converted.
60		#' @param slot_name (`character`)\cr name of the slot to be tidied.
61		#' @param col (`character`)\cr The name of the corresponding column in the tidied
62		#' tibble. Defaults to `slot_name`.
63		#' @param attributes (`flag`)\cr shoud the object's attributes, if any, be added
64		#' to the output tibble
65		#'
66		#' @return A [`tibble`]
67		#'
68		#' @keywords internal
69		#' @importFrom rlang :=
70		#' @noRd
71		h_tidy_slot <- function(obj, slot_name, col = NULL, attributes = FALSE) {
72	1732x	if (is.list(slot(obj, slot_name))) {
73	57x	return(
74	57x	lapply(
75	57x	slot(obj, slot_name),
76	57x	function(x) {
77	116x	if (is.data.frame(x)) {
78	6x	return(x)
79	110x	} else if (is.list(x) && stringr::str_detect(class(x)[1], stringr::fixed("tbl_"))) {
80		# Already tidied to a list.
81	!	return(x)
82	110x	} else if (is.numeric(x) \| is.character(x)) {
83		# tidy.numeric & tidy.character are deprecated
84	12x	return(tibble::tibble(!!{{ slot_name }} := x))
85		} else {
86	98x	return(x %>% tidy())
87		}
88		}
89		)
90		)
91		}
92	1675x	if (is(slot(obj, slot_name), "CrmPackClass")) {
93	260x	rv <- slot(obj, slot_name) %>%
94	260x	tidy()
95		} else {
96	1415x	if (is.null(col)) {
97	1415x	col <- slot_name
98		}
99	1415x	rv <- tibble::tibble({{ col }} := slot(obj, slot_name))
100		}
101	1675x	if (attributes) {
102	!	a <- h_handle_attributes(slot(obj, slot_name))
103	!	if (nrow(a) > 0) {
104	!	rv <- rv %>% dplyr::bind_cols(a)
105		}
106		}
107	1675x	rv
108		}
109
110		#' Tidy All Slots of a CrmPackObject
111		#'
112		#' @description `r lifecycle::badge("experimental")`
113		#'
114		#' A helper function that converts all the slots of a `CrmPackObject` to a
115		#' (list of) tibble(s).
116		#'
117		#' @param obj (`CrmPackObject`)\cr object to be tidied.
118		#' @param ... passed to h_tidy_slot
119		#'
120		#' @return A (list of) [`tibble`](s)
121		#'
122		#' @keywords internal
123		#' @noRd
124		h_tidy_all_slots <- function(obj, ...) {
125	523x	slot_names <- slotNames(obj)
126	523x	rv <- list()
127	523x	for (nm in slot_names) {
128	1942x	if (!is.function(slot(obj, nm))) {
129	1682x	rv[[nm]] <- h_tidy_slot(obj, nm, ...)
130		}
131		}
132		# Column bind of all list elements have the same number of rows
133	523x	if (length(rv) > 1 && length(unique(sapply(rv, nrow))) == 1) {
134	258x	rv <- rv %>% dplyr::bind_cols() # nolint
135		}
136	523x	rv
137		}
138
139		#' Amend the Class of a Tibble to Indicate that it Contains a Tidied `CrmPackObject`
140		#'
141		#' @description `r lifecycle::badge("experimental")`
142		#'
143		#' A helper function that prepends `tbl_<cls>`, where `<cls>` is the first
144		#' element of the class attribute of the original `CrmPackObject` to the class
145		#' attribute of a tibble
146		#'
147		#' @param d (`tibble`)\cr the tibble containing the tidied version of `obj`.
148		#' @param obj (`CrmPackObject`)\cr object to be converted.
149		#'
150		#' @return `d`, with an amended class attribute
151		#'
152		#' @keywords internal
153		#' @noRd
154		h_tidy_class <- function(d, obj) {
155	792x	cls <- class(obj)
156	792x	class(d) <- c(paste0("tbl_", cls[1]), class(d))
157	792x	d
158		}
159
160		#' Convert a `CrmPackObject`'s "Interval list" to a Min-Max
161		#'
162		#' @description `r lifecycle::badge("experimental")`
163		#'
164		#' `CrmPackClass` objects that define a set of intervals (such as `CohortSizeRange`)
165		#' typically contain a left-open vector that dfines the intervals. For example,
166		#' `my_size <- CohortSizeRange(intervals = c(0, 20), cohort_size = c(1, 3))` defines
167		#' two dose ranges: [0, 20) and [20, Inf). This is convenient for coding, but
168		#' awkward for reporting. This helper function converts this single-column
169		#' representation to a two-column representation that explicitly defines the
170		#' lower and upper ends of each interval. Using the example above, the converted
171		#' tibble would look like this:
172		#'
173		#' \| cohort_size \| min \| max \|
174		#' \| ----------: \| ---: \| ---: \|
175		#' \| 1 \| -Inf \| 20 \|
176		#' \| 3 \| 20 \| Inf \|
177		#'
178		#' @param x (`tibble`)\cr the tibble to be converted.
179		#' @param col (`tidy-eval`)\cr column containing the intervals.
180		#' @param min_col (`character`)\cr name of the column containing the lower end
181		#' of the interval in the returned value.
182		#' @param max_col (`character`)\cr name of the column containing the upper end
183		#' of the interval in the returned value.
184		#' @param range_min (`numeric`)\cr value of the lower end of the first interval.
185		#' @param range_max (`numeric`)\cr value of the upper end of the last interval.
186		#'
187		#' @return A `tibble` in min-max format, with one row more than the input tibble.
188		#'
189		#' @importFrom rlang :=
190		#' @keywords internal
191		#' @noRd
192		h_range_to_minmax <- function(
193		x,
194		col,
195		min_col = "min",
196		max_col = "max",
197		range_min = -Inf,
198		range_max = Inf) {
199	132x	vals <- x %>% dplyr::pull({{ col }})
200	132x	tibble(
201	132x	{{ min_col }} := c(range_min, vals),
202	132x	{{ max_col }} := c(vals, range_max)
203		)
204		}

1		# These functions will need to be amended to support the report_label slot if
2		# and when it is added to NextBest classes
3
4		# NextBestMTD ----
5
6		#' @description `r lifecycle::badge("experimental")`
7		#' @inheritParams knit_print.StoppingTargetProb
8		#' @param target_label (`character`)\cr the term used to describe the target
9		#' toxicity rate
10		#' @rdname knit_print
11		#' @export
12		#' @method knit_print NextBestMTD
13		knit_print.NextBestMTD <- function(
14		x,
15		...,
16		target_label = "the 25th centile",
17		tox_label = "toxicity",
18		asis = TRUE) {
19		# Validate
20	12x	assert_flag(asis)
21	10x	assert_character(tox_label, len = 1, any.missing = FALSE)
22	10x	assert_character(target_label, len = 1, any.missing = FALSE)
23
24		# Execute
25	10x	rv <- paste0(
26	10x	"The dose level recommended for the next cohort will be selected as follows:\n\n",
27	10x	"- First, ",
28	10x	target_label,
29	10x	" of the posterior distribution of ",
30	10x	tox_label,
31	10x	" will be calculated for all dose levels that are eligible according to the ",
32	10x	" Increments rule.\n",
33	10x	"- Next, the \"target dose\" (which may not be part of the dose grid) for which ",
34	10x	target_label,
35	10x	" of the posterior distribution of ",
36	10x	tox_label,
37	10x	" is exactly equal to the target rate of ",
38	10x	x@target,
39	10x	" will be determined.\n",
40	10x	"- Finally, the dose level whose absolute distance from the target dose ",
41	10x	"is smallest will be selected as the recommended dose for the next cohort\n\n"
42		)
43
44	10x	if (asis) {
45	4x	rv <- knitr::asis_output(rv)
46		}
47	10x	rv
48		}
49
50		# NextBestNCRM ----
51
52		#' @description `r lifecycle::badge("experimental")`
53		#' @inheritParams knit_print.StoppingTargetProb
54		#' @rdname knit_print
55		#' @export
56		#' @method knit_print NextBestNCRM
57		knit_print.NextBestNCRM <- function(
58		x,
59		...,
60		tox_label = "toxicity",
61		asis = TRUE) {
62		# Validate
63	7x	assert_flag(asis)
64	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
65
66		# Execute
67	5x	rv <- paste0(
68	5x	"The dose recommended for the next cohort will be chosen in the following ",
69	5x	"way. First, doses that are ineligible according to the increments rule ",
70	5x	"will be discarded. Next, any dose for which the mean posterior probability of ",
71	5x	tox_label,
72	5x	" being in the overdose range - (",
73	5x	x@overdose[1], ", ", x@overdose[2],
74	5x	"] - is ",
75	5x	x@max_overdose_prob,
76	5x	" or more will also be discarded. Finally, the dose amongst those remaining ",
77	5x	"which has the highest chance that the mean posterior probability of ",
78	5x	tox_label,
79	5x	" is in the target ",
80	5x	tox_label,
81	5x	" range of ",
82	5x	x@target[1],
83	5x	" to ",
84	5x	x@target[2],
85	5x	" (inclusive) will be selected."
86		)
87
88	5x	if (asis) {
89	2x	rv <- knitr::asis_output(rv)
90		}
91	5x	rv
92		}
93
94		# NextBestThreePlusThree ----
95
96		#' @description `r lifecycle::badge("experimental")`
97		#' @param participant_label (`character`)\cr The term used to label the participants.
98		#' @param tox_label (`character`)\cr the term used to describe toxicity. See
99		#' Usage Notes below.
100		#' See Usage Notes below.
101		#' @section Usage Notes:
102		#' This section describes the use of `participant_label` and `tox_label`, collectively
103		#' referred to as `label`s.
104		#' A `label` should be a scalar or a vector of length 2. If a scalar, it is
105		#' converted by adding a second element that is equal to the first, suffixed by `s`.
106		#' For example, `tox_label = "DLT"` becomes `tox_label = c("DLT", "DLTs")`. The
107		#' first element of the vector is used to describe a count of 1. The second
108		#' is used in all other cases.
109		#' @rdname knit_print
110		#' @export
111		#' @method knit_print NextBestThreePlusThree
112		knit_print.NextBestThreePlusThree <- function(
113		x,
114		...,
115		tox_label = c("toxicity", "toxicities"),
116		participant_label = "participant",
117		asis = TRUE) {
118		# Validate
119	7x	assert_flag(asis)
120	5x	assert_character(tox_label, min.len = 1, max.len = 2, any.missing = FALSE)
121
122		# Prepare
123	5x	if (length(tox_label == 1)) {
124	5x	tox_label <- c(tox_label, paste0(tox_label, "s"))
125		}
126	5x	if (length(participant_label == 1)) {
127	5x	participant_label <- c(participant_label, paste0(participant_label, "s"))
128		}
129
130		# Execute
131	5x	rv <- paste0(
132	5x	"The dose recommended for the next cohort will be chosen using the \"Three ",
133	5x	"Plus Three\" rule.\n\n- If no ",
134	5x	tox_label[2],
135	5x	" have been reported at the current dose level, escalate by one dose level.\n",
136	5x	"- If the observed ",
137	5x	tox_label[1],
138	5x	" rate at the current dose level is exactly 1/3 and no more than three ",
139	5x	participant_label[2],
140	5x	" treated at the current dose level are evaluable, remain at the current ",
141	5x	"dose level.\n",
142	5x	"- Otherwise, recommend that the trial stops and identify the MTD as dose ",
143	5x	"level immediately below the current one."
144		)
145
146	5x	if (asis) {
147	2x	rv <- knitr::asis_output(rv)
148		}
149	5x	rv
150		}
151
152		# NextBestDualEndpoint ----
153
154		#' @description `r lifecycle::badge("experimental")`
155		#' @inheritParams knit_print.StoppingTargetProb
156		#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
157		#' @param biomarker_units (`character`)\cr the units in which the biomarker is
158		#' measured
159		#' @rdname knit_print
160		#' @export
161		#' @method knit_print NextBestDualEndpoint
162		knit_print.NextBestDualEndpoint <- function(
163		x,
164		...,
165		tox_label = "toxicity",
166		biomarker_label = "the biomarker",
167		biomarker_units = ifelse(x@target_relative, "%", ""),
168		asis = TRUE) {
169	7x	assert_flag(asis)
170	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
171	5x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
172	5x	assert_character(biomarker_units, len = 1, any.missing = FALSE)
173
174	5x	rv <- paste0(
175	5x	"The dose recommended for the next cohort will be chosen in the following ",
176	5x	"way. First, doses that are ineligible according to the increments rule ",
177	5x	"will be discarded. Next, any dose for which the mean posterior probability of ",
178	5x	tox_label,
179	5x	" being in the overdose range - (",
180	5x	x@overdose[1], ", ", x@overdose[2],
181	5x	"] - is ",
182	5x	x@max_overdose_prob,
183	5x	" or more will also be discarded. Finally, the dose amongst those remaining ",
184	5x	"which has the highest chance that the mean posterior probability that ",
185	5x	biomarker_label,
186	5x	" is in the target range for ",
187	5x	biomarker_label,
188	5x	", which is ",
189	5x	x@target[1],
190	5x	ifelse(x@target_relative, "", stringr::str_squish(paste0(" ", biomarker_units))),
191	5x	" to ",
192	5x	x@target[2],
193	5x	ifelse(x@target_relative, "", stringr::str_squish(paste0(" ", biomarker_units))),
194	5x	" (inclusive),",
195	5x	ifelse(
196	5x	x@target_relative,
197	5x	paste0(" of the maximum ", biomarker_label, " value"),
198		""
199		),
200	5x	" will be selected, provided that this probability exceeds ",
201	5x	x@target_thresh,
202	5x	". If no dose meets this threshold, then the highest eligible dose will ",
203	5x	"be selected."
204		)
205
206	5x	if (asis) {
207	2x	rv <- knitr::asis_output(rv)
208		}
209	5x	rv
210		}
211
212		# NextBestMinDist ----
213
214		#' @description `r lifecycle::badge("experimental")`
215		#' @inheritParams knit_print.StoppingTargetProb
216		#' @rdname knit_print
217		#' @export
218		#' @method knit_print NextBestMinDist
219		knit_print.NextBestMinDist <- function(
220		x,
221		...,
222		tox_label = "toxicity",
223		asis = TRUE) {
224		# Validate
225	7x	assert_flag(asis)
226	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
227
228		# Execute
229	5x	rv <- paste0(
230	5x	"The dose recommended for the next cohort will be the one which is both ",
231	5x	"eligible and which has the smallest absolute difference between ",
232	5x	"its mean posterior estimate of the probability of ",
233	5x	tox_label,
234	5x	" and the target ",
235	5x	tox_label,
236	5x	" rate [",
237	5x	x@target,
238		"]."
239		)
240
241	5x	if (asis) {
242	2x	rv <- knitr::asis_output(rv)
243		}
244	5x	rv
245		}
246
247		# NextBestInfTheory ----
248
249		#' @description `r lifecycle::badge("experimental")`
250		#' @inheritParams knit_print.StoppingTargetProb
251		#' @param citation_text (`character`)\cr the text used to cite Mozgunov & Jaki
252		#' @param citation_link (`character`)\cr the link to Mozgunov & Jaki
253		#' @section Usage Notes:
254		#' To use a BibTeX-style citation, specify (for example) `citation_text =
255		#' "@MOZGUNOV", citation_link = ""`.
256		#' @rdname knit_print
257		#' @export
258		#' @method knit_print NextBestInfTheory
259		knit_print.NextBestInfTheory <- function(
260		x,
261		...,
262		tox_label = "toxicity",
263		citation_text = "Mozgunov & Jaki (2019)",
264		citation_link = "https://doi.org/10.1002/sim.8450",
265		asis = TRUE) {
266		# Validate
267	7x	assert_flag(asis)
268	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
269	5x	assert_character(citation_text, len = 1, any.missing = FALSE)
270	5x	assert_character(citation_link, len = 1, any.missing = FALSE)
271
272		# Execute
273	5x	rv <- paste0(
274	5x	"The recommended dose for the next cohort will be chosen using the ",
275	5x	"complex infinite bounds penalisation (CIBP) criterion of ",
276	5x	"[", citation_text, "]",
277	5x	ifelse(nchar(citation_link) > 0, paste0("(", citation_link, ")"), ""),
278	5x	". Let\n\n",
279	5x	"$$ \\delta(\\hat{p}_d, \\gamma) = \\frac{(\\hat{p}_d - \\gamma)^2}",
280	5x	"{\\hat{p}_d^a \\cdot (1 - \\hat{p}_d)^{2 - a}} $$\n\n",
281	5x	"where a is the non-centrality parameter with a value of ",
282	5x	x@asymmetry,
283	5x	", γ is the target ",
284	5x	tox_label,
285	5x	" rate with a value of ",
286	5x	x@target,
287	5x	" and $\\hat{p}_d$ is the mean posterior estimate of the probability of ",
288	5x	tox_label,
289	5x	" at dose level d.\n\n",
290	5x	"The recommended dose for the next cohort will be ",
291	5x	"the value of d that minimises $\\delta(\\hat{p}_d, \\gamma)$."
292		)
293
294	5x	if (asis) {
295	2x	rv <- knitr::asis_output(rv)
296		}
297	5x	rv
298		}
299
300		# NextBestTD ----
301
302		#' @description `r lifecycle::badge("experimental")`
303		#' @inheritParams knit_print.StoppingTargetProb
304		#' @rdname knit_print
305		#' @export
306		#' @method knit_print NextBestTD
307		knit_print.NextBestTD <- function(
308		x,
309		...,
310		tox_label = "toxicity",
311		asis = TRUE) {
312		# Validate
313	7x	assert_flag(asis)
314	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
315
316		# Execute
317	5x	rv <- paste0(
318	5x	"The dose recommended for the next cohort will be the one which is both ",
319	5x	"eligible and which is the highest dose in the dose grid strictly less than ",
320	5x	"the dose (which may not be in the dose grid) that has a posterior plug-in ",
321	5x	"estimate of the probability of ",
322	5x	tox_label,
323	5x	" exactly equal to the target ",
324	5x	tox_label,
325	5x	" rate, either during [",
326	5x	x@prob_target_drt,
327	5x	"] or at the end of the trial [",
328	5x	x@prob_target_eot,
329		"]."
330		)
331
332	5x	if (asis) {
333	2x	rv <- knitr::asis_output(rv)
334		}
335	5x	rv
336		}
337
338		# NextBestMaxGain ----
339
340		#' @description `r lifecycle::badge("experimental")`
341		#' @inheritParams knit_print.StoppingTargetProb
342		#' @rdname knit_print
343		#' @export
344		#' @method knit_print NextBestMaxGain
345		knit_print.NextBestMaxGain <- function(
346		x,
347		...,
348		tox_label = "toxicity",
349		asis = TRUE) {
350		# Validate
351	7x	assert_flag(asis)
352	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
353
354		# Execute
355	5x	rv <- paste0(
356	5x	"The dose recommended for the next cohort will be the one which is closest to ",
357	5x	"Gstar, the dose that maximises the gain for probability of ",
358	5x	tox_label,
359	5x	" exactly equal to the target ",
360	5x	tox_label,
361	5x	" rate, either during [",
362	5x	x@prob_target_drt,
363	5x	"] or at the end of the trial [",
364	5x	x@prob_target_eot,
365		"]."
366		)
367
368	5x	if (asis) {
369	2x	rv <- knitr::asis_output(rv)
370		}
371	5x	rv
372		}
373
374		# NextBestProbMTDLTE ----
375
376		#' @description `r lifecycle::badge("experimental")`
377		#' @inheritParams knit_print.StoppingTargetProb
378		#' @rdname knit_print
379		#' @export
380		#' @method knit_print NextBestProbMTDLTE
381		knit_print.NextBestProbMTDLTE <- function(
382		x,
383		...,
384		tox_label = "toxicity",
385		asis = TRUE) {
386		# Validate
387	7x	assert_flag(asis)
388	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
389
390		# Execute
391	5x	rv <- paste0(
392	5x	"The dose recommended for the next cohort will be the dose level with ",
393	5x	"the highest probability of being the highest dose with an estimated ",
394	5x	"probability of ",
395	5x	tox_label,
396	5x	" less than or equal to ",
397	5x	x@target,
398		"."
399		)
400
401	5x	if (asis) {
402	2x	rv <- knitr::asis_output(rv)
403		}
404	5x	rv
405		}
406
407		# NextBestProbMTDMinDist ----
408
409		#' @description `r lifecycle::badge("experimental")`
410		#' @inheritParams knit_print.StoppingTargetProb
411		#' @rdname knit_print
412		#' @export
413		#' @method knit_print NextBestProbMTDMinDist
414		knit_print.NextBestProbMTDMinDist <- function(
415		x,
416		...,
417		tox_label = "toxicity",
418		asis = TRUE) {
419		# Validate
420	7x	assert_flag(asis)
421	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
422
423		# Execute
424	5x	rv <- paste0(
425	5x	"The dose recommended for the next cohort will be the dose level with ",
426	5x	"the highest probability of being the highest dose with an estimated ",
427	5x	"probability of ",
428	5x	tox_label,
429	5x	" closest to ",
430	5x	x@target,
431		"."
432		)
433
434	5x	if (asis) {
435	2x	rv <- knitr::asis_output(rv)
436		}
437	5x	rv
438		}
439
440		# NextBestNCRMLoss ----
441
442		#' @description `r lifecycle::badge("experimental")`
443		#' @inheritParams knit_print.StoppingTargetProb
444		#' @param format_func (`function`)\cr The function used to format the range table.
445		#' @importFrom rlang .data
446		#' @rdname knit_print
447		#' @export
448		#' @method knit_print NextBestNCRMLoss
449		knit_print.NextBestNCRMLoss <- function(
450		x,
451		...,
452		tox_label = "toxicity",
453		asis = TRUE,
454		format_func = function(x) {
455	4x	kableExtra::kable_styling(
456	4x	x,
457	4x	bootstrap_options = c("striped", "hover", "condensed")
458		)
459		}) {
460		# Validate
461	7x	assert_flag(asis)
462	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
463
464		# Execute
465	5x	param <- list(...)
466	5x	param[["x"]] <- x %>%
467	5x	tidy() %>%
468	5x	dplyr::select(-.data$MaxOverdoseProb)
469	5x	param[["col.names"]] <- c("Range", "Lower", "Upper", "Loss Coefficient")
470	5x	rv <- paste0(
471	5x	"The dose recommended for the next cohort will be chosen in the following ",
472	5x	"way:\n\n- First, the chance that the probability of ",
473	5x	tox_label,
474	5x	" falls into each of the underdose, target ",
475	5x	ifelse(
476	5x	any(x@unacceptable != c(1, 1)),
477	5x	", overdose and unacceptable",
478	5x	" and overdose"
479		),
480	5x	" dose ranges is calculated for element of the dose grid.\n",
481	5x	"- Next, the loss associated with each dose is calculated by multiplying ",
482	5x	"these probabilities by the corresponding loss coefficient and summing the result.\n",
483	5x	"- Then ineligible doses, and those with a probability of being in the ",
484	5x	ifelse(
485	5x	length(x@losses) == 3,
486	5x	"overdose range",
487	5x	"overdose or unaccaptable ranges"
488		),
489	5x	" that is greater than ",
490	5x	x@max_overdose_prob,
491	5x	", are discarded.\n",
492	5x	"- Finally, the dose level with the smallest loss is selected as the ",
493	5x	"recommended dose for the next cohort.\n\n",
494	5x	ifelse(
495	5x	toupper(tox_label) == tox_label,
496	5x	tox_label,
497	5x	stringr::str_to_sentence(tox_label)
498		),
499	5x	" ranges and loss coefficients are given in the following table:\n\n",
500	5x	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
501		)
502
503	5x	if (asis) {
504	2x	rv <- knitr::asis_output(rv)
505		}
506	5x	rv
507		}
508
509		# NextBestTDsamples ----
510
511		#' @description `r lifecycle::badge("experimental")`
512		#' @inheritParams knit_print.StoppingTargetProb
513		#' @rdname knit_print
514		#' @export
515		#' @method knit_print NextBestTDsamples
516		knit_print.NextBestTDsamples <- function(
517		x,
518		...,
519		tox_label = "toxicity",
520		asis = TRUE) {
521		# Validate
522	7x	assert_flag(asis)
523	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
524
525		# Execute
526	5x	rv <- paste0(
527	5x	"The dose recommended for the next cohort will be the one which is both ",
528	5x	"eligible and which is the highest dose in the dose grid strictly less than ",
529	5x	"the dose (which may not be in the dose grid) that has a full Bayes posterior ",
530	5x	"estimate of the probability of ",
531	5x	tox_label,
532	5x	" exactly equal to the target ",
533	5x	tox_label,
534	5x	" rate, either during [",
535	5x	x@prob_target_drt,
536	5x	"] or at the end of the trial [",
537	5x	x@prob_target_eot,
538		"]."
539		)
540
541	5x	if (asis) {
542	2x	rv <- knitr::asis_output(rv)
543		}
544	5x	rv
545		}
546
547
548		# NextBestMaxGainSamples ----
549
550		#' @description `r lifecycle::badge("experimental")`
551		#' @inheritParams knit_print.StoppingTargetProb
552		#' @rdname knit_print
553		#' @export
554		#' @method knit_print NextBestMaxGainSamples
555		knit_print.NextBestMaxGainSamples <- function(
556		x,
557		...,
558		tox_label = "toxicity",
559		asis = TRUE) {
560		# Validate
561	7x	assert_flag(asis)
562	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
563
564		# Execute
565	5x	rv <- paste0(
566	5x	"The dose recommended for the next cohort will be the one which is closest to ",
567	5x	"Gstar, the dose for which the full Bayes posterior estimate of the probability of ",
568	5x	tox_label,
569	5x	" maximises the gain relative to the target ",
570	5x	tox_label,
571	5x	" rate, either during [",
572	5x	x@prob_target_drt,
573	5x	"] or at the end of the trial [",
574	5x	x@prob_target_eot,
575		"]."
576		)
577
578	5x	if (asis) {
579	2x	rv <- knitr::asis_output(rv)
580		}
581	5x	rv
582		}
583
584		# NextBestOrdinal ----
585
586		#' @description `r lifecycle::badge("experimental")`
587		#' @inheritParams knit_print.StoppingTargetProb
588		#' @rdname knit_print
589		#' @export
590		#' @method knit_print NextBestOrdinal
591		knit_print.NextBestOrdinal <- function(
592		x,
593		...,
594		asis = TRUE) {
595	7x	assert_flag(asis)
596
597	5x	rv <- paste0(
598	5x	"Based on a toxicity grade of ",
599	5x	x@grade,
600		": ",
601	5x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
602		)
603
604	5x	if (asis) {
605	2x	rv <- knitr::asis_output(rv)
606		}
607	5x	rv
608		}

1		#' Update [`DualEndpoint`] class model components with regard to biomarker
2		#' regression variance.
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#'
6		#' A simple helper function that takes [`DualEndpoint`] model existing components
7		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
8		#' to biomarker regression variance `sigma2W`.
9		#'
10		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for the biomarker
11		#' regression variance `sigma2W` should be used or not. If `sigma2W` is not
12		#' supposed to be a fixed value, a prior distribution from the Inverse-Gamma
13		#' distribution will be used. See the details below, under `sigma2W` argument.
14		#' @param sigma2W (`numeric`)\cr the biomarker variance. Either a fixed value or
15		#' Inverse-Gamma distribution parameters, i.e. vector with two elements named
16		#' `a` and `b`.
17		#' @param comp (`list`)\cr a named list with model components that will be updated.
18		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
19		#' definitions of the components, see [`GeneralModel`] class.
20		#' The `modelspecs` and `init` components on `comp` list are specified up to
21		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
22		#' functions. These bodies are simply a lists itself.
23		#'
24		#' @return `list` with updated model components.
25		#'
26		#' @export
27		h_model_dual_endpoint_sigma2W <- function(use_fixed, # nolintr
28		sigma2W,
29		comp) {
30	202x	if (use_fixed) {
31	114x	assert_number(sigma2W, lower = 0 + .Machine$double.xmin, finite = TRUE)
32	112x	comp$modelspecs$precW <- 1 / sigma2W
33		} else {
34	88x	assert_true(h_test_named_numeric(sigma2W, permutation.of = c("a", "b")))
35	87x	comp$priormodel <- h_jags_join_models(
36	87x	comp$priormodel,
37	87x	function() {
38	!	precW ~ dgamma(precWa, precWb)
39		}
40		)
41	87x	comp$modelspecs$precWa <- sigma2W[["a"]]
42	87x	comp$modelspecs$precWb <- sigma2W[["b"]]
43	87x	comp$init$precW <- 1
44	87x	comp$sample <- c(comp$sample, "precW")
45		}
46	199x	comp
47		}
48
49		#' Update [`DualEndpoint`] class model components with regard to DLT and biomarker
50		#' correlation.
51		#'
52		#' @description `r lifecycle::badge("stable")`
53		#'
54		#' A simple helper function that takes [`DualEndpoint`] model existing components
55		#' (`priormodel`, `modelspecs`, `init`, `sample`), and updates them with regard to
56		#' DLT and biomarker correlation `rho`.
57		#'
58		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for DLT and
59		#' biomarker correlation `rho` should be used or not. If `rho` is not supposed
60		#' to be a fixed value, a prior distribution from the scaled Beta family will
61		#' be used. See the details below, under `rho` argument.
62		#' @param rho (`numeric`)\cr DLT and biomarker correlation. It must be either a
63		#' fixed value (between `-1` and `1`), or a named vector with two elements,
64		#' named `a` and `b` for the Beta prior on the transformation
65		#' `kappa = (rho + 1) / 2`, which is in `(0, 1)`. For example, `a = 1, b = 1`
66		#' leads to a uniform prior on `rho`.
67		#' @param comp (`list`)\cr a named list with model components that will be updated.
68		#' The names should be: `priormodel`, `modelspecs`, `init`, `sample`. For
69		#' definitions of the components, see [`GeneralModel`] class.
70		#' The `modelspecs` and `init` components on `comp` list are specified up to
71		#' the body of corresponding `GeneralModel@modelspecs` and `GeneralModel@init`
72		#' functions. These bodies are simply a lists itself.
73		#'
74		#' @return A `list` with updated model components.
75		#'
76		#' @export
77		h_model_dual_endpoint_rho <- function(use_fixed,
78		rho,
79		comp) {
80	203x	rmin <- .Machine$double.xmin
81	203x	if (use_fixed) {
82	115x	assert_number(rho, lower = -1 + rmin, upper = 1 - rmin)
83	112x	comp$modelspecs$rho <- rho
84		} else {
85	88x	assert_true(h_test_named_numeric(rho, permutation.of = c("a", "b")))
86	87x	comp$priormodel <- h_jags_join_models(
87	87x	comp$priormodel,
88	87x	function() {
89	!	kappa ~ dbeta(rhoa, rhob)
90	!	rho <- 2 * kappa - 1
91		}
92		)
93	87x	comp$modelspecs$rhoa <- rho[["a"]]
94	87x	comp$modelspecs$rhob <- rho[["b"]]
95	87x	comp$init$kappa <- 0.5
96	87x	comp$sample <- c(comp$sample, "rho")
97		}
98	199x	comp
99		}
100
101		#' Update certain components of [`DualEndpoint`] model with regard to prior variance
102		#' factor of the random walk.
103		#'
104		#' @description `r lifecycle::badge("stable")`
105		#'
106		#' A simple helper function that takes [`DualEndpoint`] object and updates
107		#' `priormodel`, `modelspecs`, `init`, `sample` slots according to the random walk
108		#' variance.
109		#'
110		#' @param use_fixed (`flag`)\cr indicates whether a fixed value for
111		#' `sigma2betaW` should be used or not. If `sigma2betaW` is not supposed
112		#' to be a fixed value, a prior distribution from the Inverse-Gamma distribution
113		#' will be used. See the details below, under `sigma2betaW` argument.
114		#' @param sigma2betaW (`numeric`)\cr the prior variance factor of the random walk
115		#' prior for the biomarker model. Either a fixed value or Inverse-Gamma distribution
116		#' parameters, i.e. vector with two elements named `a` and `b`.
117		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
118		#'
119		#' @return A [`DualEndpoint`] model with updated `priormodel`, `modelspecs`,
120		#' `init`, `sample` slots.
121		#'
122		#' @seealso [`DualEndpointRW`].
123		#' @export
124		h_model_dual_endpoint_sigma2betaW <- function(use_fixed, # nolintr
125		sigma2betaW,
126		de) {
127	55x	modelspecs <- de@modelspecs
128	55x	init <- de@init
129
130	55x	if (use_fixed) {
131	43x	assert_number(sigma2betaW, lower = 0 + .Machine$double.xmin, finite = TRUE)
132	41x	ms <- list(precBetaW = 1 / sigma2betaW)
133		} else {
134	12x	assert_true(h_test_named_numeric(sigma2betaW, permutation.of = c("a", "b")))
135		# gamma prior for random walk precision.
136	11x	de@priormodel <- h_jags_join_models(
137	11x	de@priormodel,
138	11x	function() {
139	!	precBetaW ~ dgamma(precBetaWa, precBetaWb)
140		}
141		)
142	11x	ms <- list(precBetaWa = sigma2betaW[["a"]], precBetaWb = sigma2betaW[["b"]])
143	11x	de@init <- function(y) {
144	10x	c(init(y), list(precBetaW = 1))
145		}
146	11x	de@sample <- c(de@sample, "precBetaW")
147		}
148	52x	de@modelspecs <- function(from_prior) {
149	39x	c(modelspecs(from_prior), ms)
150		}
151	52x	de
152		}
153
154		#' Update certain components of [`DualEndpoint`] model with regard to parameters
155		#' of the function that models dose-biomarker relationship defined in the
156		#' [`DualEndpointBeta`] class.
157		#'
158		#' @description `r lifecycle::badge("stable")`
159		#'
160		#' A simple helper function that takes [`DualEndpoint`] object and updates
161		#' `use_fixed`, `priormodel`, `modelspecs`, `init`, `sample` slots with regard
162		#' to a given parameter of the dose-biomarker relationship \eqn{f(x)} defined in
163		#' the [`DualEndpointBeta`] class. This update solely depends on whether a given
164		#' parameter's value `param` is a fixed-valued scalar or two-elements numeric
165		#' vector. In the later case, it is assumed that `param` represents two
166		#' parameters of a probability distribution that will be used in `priormodel`
167		#' function to generate values for the `param_name` parameter of \eqn{f(x)}.
168		#' See the help page for [`DualEndpointBeta`] class for more details.
169		#'
170		#' @param param (`numeric`)\cr the value of a given `param_name` parameter of
171		#' the dose-biomarker relationship function \eqn{f(x)}. Either a fixed-valued
172		#' scalar or vector with two elements that are the parameters of a probability
173		#' distribution that will be used in `priormodel` function to generate values
174		#' for the `param_name` parameter of \eqn{f(x)}.
175		#' @param param_name (`string`)\cr the name of the parameter of \eqn{f(x)},
176		#' whose value depends on `param`.
177		#' @param param_suffix (`character`)\cr the two suffixes to be appended to
178		#' the elements of `param_name` and then used when updating `modelspecs`.
179		#' The value of this argument is ignored when `param` is a scalar.
180		#' @param priormodel (`function` or `NULL`)\cr a function representing the
181		#' `JAGS` prior specification that will be appended to existing
182		#' `de@priormodel` specification if `param` is not a scalar. Otherwise,
183		#' `de@priormodel` remains unchanged.
184		#' @param de (`DualEnpoint`)\cr dual endpoint model whose slots will be updated.
185		#'
186		#' @return A [`DualEndpoint`] model with updated `use_fixed`, `priormodel`,
187		#' `modelspecs`, `init`, `sample` slots.
188		#'
189		#' @export
190		h_model_dual_endpoint_beta <- function(param,
191		param_name,
192		param_suffix = c("_low", "_high"),
193		priormodel = NULL,
194		de) {
195	172x	assert_numeric(param, min.len = 1, max.len = 2, any.missing = FALSE)
196	171x	assert_string(param_name)
197	170x	assert_class(de, "DualEndpoint")
198
199	170x	use_fixed <- setNames(test_number(param), param_name)
200	170x	modelspecs <- de@modelspecs
201	170x	init <- de@init
202
203	170x	if (use_fixed) {
204	81x	ms <- setNames(list(param), param_name)
205		} else {
206	89x	assert_character(param_suffix, len = 2, unique = TRUE, any.missing = FALSE)
207	88x	assert_function(priormodel)
208	87x	param_name2 <- paste0(param_name, param_suffix)
209
210	87x	de@priormodel <- h_jags_join_models(
211	87x	de@priormodel,
212	87x	priormodel
213		)
214	87x	ms <- setNames(list(param[1], param[2]), param_name2)
215	87x	de@init <- function(y) {
216	21x	c(init(y), setNames(list(mean(param)), param_name))
217		}
218	87x	de@sample <- c(de@sample, param_name)
219		}
220	168x	de@modelspecs <- function(from_prior) {
221	60x	c(modelspecs(from_prior), ms)
222		}
223	168x	de@use_fixed <- c(de@use_fixed, use_fixed)
224	168x	de
225		}
226
227		#' Convert an ordinal CRM model to the Equivalent Binary CRM Model for a Specific
228		#' Grade
229		#'
230		#' @description `r lifecycle::badge("experimental")`
231		#'
232		#' A simple helper function that takes a [`LogisticLogNormalOrdinal`] and an
233		#' integer grade and converts them to the equivalent `LogisticLogNormal` model.
234		#'
235		#' @param x (`LogisticLogNormalOrdinal`)\cr the `LogisticLogNormalOrdinal`
236		#' model to covert
237		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent model
238		#' is required.
239		#' @return A [`LogisticLogNormal`] model.
240		#'
241		#' @export
242		h_convert_ordinal_model <- function(x, grade) {
243		# Validate
244	21x	assert_integer(grade, len = 1, lower = 1)
245	21x	assert_class(x, "LogisticLogNormalOrdinal")
246		# Execute
247	21x	LogisticLogNormal(
248	21x	mean = x@params@mean[-grade],
249	21x	cov = x@params@cov[-grade, -grade],
250	21x	ref_dose = x@ref_dose
251		)
252		}

1		##' @include helpers.R
2		##' @include Model-class.R
3		NULL
4
5		# nolint start
6
7		##' Convert prior quantiles (lower, median, upper) to logistic (log)
8		##' normal model
9		##'
10		##' This function uses generalized simulated annealing to optimize
11		##' a \code{\linkS4class{LogisticNormal}} model to be as close as possible
12		##' to the given prior quantiles.
13		##'
14		##' @param dosegrid the dose grid
15		##' @param refDose the reference dose
16		##' @param lower the lower quantiles
17		##' @param median the medians
18		##' @param upper the upper quantiles
19		##' @param level the credible level of the (lower, upper) intervals (default:
20		##' 0.95)
21		##' @param logNormal use the log-normal prior? (not default) otherwise, the
22		##' normal prior for the logistic regression coefficients is used
23		##' @param parstart starting values for the parameters. By default, these
24		##' are determined from the medians supplied.
25		##' @param parlower lower bounds on the parameters (intercept alpha and the
26		##' slope beta, the corresponding standard deviations and the correlation.)
27		##' @param parupper upper bounds on the parameters
28		##' @param seed seed for random number generation
29		##' @param verbose be verbose? (default)
30		##' @param control additional options for the optimisation routine, see
31		##' \code{\link[GenSA]{GenSA}} for more details
32		##' @return a list with the best approximating \code{model}
33		##' (\code{\linkS4class{LogisticNormal}} or
34		##' \code{\linkS4class{LogisticLogNormal}}), the resulting \code{quantiles}, the
35		##' \code{required} quantiles and the \code{distance} to the required quantiles,
36		##' as well as the final \code{parameters} (which could be used for running the
37		##' algorithm a second time)
38		##'
39		##' @importFrom GenSA GenSA
40		##' @importFrom mvtnorm rmvnorm
41		##' @export
42		##' @keywords programming
43		Quantiles2LogisticNormal <- function(dosegrid,
44		refDose,
45		lower,
46		median,
47		upper,
48		level = 0.95,
49		logNormal = FALSE,
50		parstart = NULL,
51		parlower = c(-10, -10, 0, 0, -0.95),
52		parupper = c(10, 10, 10, 10, 0.95),
53		seed = 12345,
54		verbose = TRUE,
55		control =
56		list(
57		threshold.stop = 0.01,
58		maxit = 50000,
59		temperature = 50000,
60		max.time = 600
61		)) {
62		## extracts and checks
63	2x	nDoses <- length(dosegrid)
64
65	2x	assert_flag(logNormal)
66	2x	assert_flag(verbose)
67	2x	assert_probability(level, bounds_closed = FALSE)
68	2x	stopifnot(
69	2x	!is.unsorted(dosegrid, strictly = TRUE),
70		## the medians must be monotonically increasing:
71	2x	!is.unsorted(median),
72	2x	identical(length(lower), nDoses),
73	2x	identical(length(median), nDoses),
74	2x	identical(length(upper), nDoses),
75	2x	all(lower < median),
76	2x	all(upper > median),
77	2x	identical(length(parlower), 5L),
78	2x	identical(length(parupper), 5L),
79	2x	all(parlower < parstart),
80	2x	all(parstart < parupper)
81		)
82
83		## put verbose argument in the control list
84	2x	control$verbose <- verbose
85
86		## parametrize in terms of the means for the intercept alpha and the
87		## (log) slope beta,
88		## the corresponding standard deviations and the correlation.
89		## Define start values for optimisation:
90	2x	startValues <-
91	2x	if (is.null(parstart)) {
92		## find approximate means for alpha and slope beta
93		## from fitting logistic model to medians:
94	1x	startAlphaBeta <-
95	1x	coef(lm(I(logit(median)) ~ I(log(dosegrid / refDose))))
96
97		## overall starting values:
98	1x	c(
99	1x	meanAlpha =
100	1x	startAlphaBeta[1],
101	1x	meanBeta =
102	1x	if (logNormal) log(startAlphaBeta[2]) else startAlphaBeta[2],
103	1x	sdAlpha =
104	1x	1,
105	1x	sdBeta =
106	1x	1,
107	1x	correlation =
108	1x	0
109		)
110		} else {
111	1x	parstart
112		}
113
114		## what is the target function which we want to minimize?
115	2x	target <- function(param) {
116		## form the mean vector and covariance matrix
117	4x	mean <- param[1:2]
118	4x	cov <- matrix(
119	4x	c(
120	4x	param[3]^2,
121	4x	prod(param[3:5]),
122	4x	prod(param[3:5]),
123	4x	param[4]^2
124		),
125	4x	nrow = 2L, ncol = 2L
126		)
127
128		## simulate from the corresponding normal distribution
129	4x	set.seed(seed)
130	4x	normalSamples <- mvtnorm::rmvnorm(
131	4x	n = 1e4L,
132	4x	mean = mean,
133	4x	sigma = cov
134		)
135
136		## extract separate coefficients
137	4x	alphaSamples <- normalSamples[, 1L]
138	4x	betaSamples <- if (logNormal) exp(normalSamples[, 2L]) else normalSamples[, 2L]
139
140		## and compute resulting quantiles
141	4x	quants <- matrix(
142	4x	nrow = length(dosegrid),
143	4x	ncol = 3L
144		)
145	4x	colnames(quants) <- c("lower", "median", "upper")
146
147		## process each dose after another:
148	4x	for (i in seq_along(dosegrid))
149		{
150		## create samples of the probability
151	20x	probSamples <-
152	20x	plogis(alphaSamples + betaSamples * log(dosegrid[i] / refDose))
153
154		## compute lower, median and upper quantile
155	20x	quants[i, ] <-
156	20x	quantile(probSamples,
157	20x	probs = c((1 - level) / 2, 0.5, (1 + level) / 2)
158		)
159		}
160
161		## now we can compute the target value
162	4x	ret <- max(abs(quants - c(lower, median, upper)))
163	4x	return(structure(ret,
164	4x	mean = mean,
165	4x	cov = cov,
166	4x	quantiles = quants
167		))
168		}
169
170	2x	set.seed(seed)
171		## now optimise the target
172	2x	genSAres <- GenSA::GenSA(
173	2x	par = startValues,
174	2x	fn = target,
175	2x	lower = parlower,
176	2x	upper = parupper,
177	2x	control = control
178		)
179	2x	distance <- genSAres$value
180	2x	pars <- genSAres$par
181	2x	targetRes <- target(pars)
182
183		## and construct the model
184	2x	ret <-
185	2x	if (logNormal) {
186	1x	LogisticLogNormal(
187	1x	mean = attr(targetRes, "mean"),
188	1x	cov = attr(targetRes, "cov"),
189	1x	ref_dose = refDose
190		)
191		} else {
192	1x	LogisticNormal(
193	1x	mean = attr(targetRes, "mean"),
194	1x	cov = attr(targetRes, "cov"),
195	1x	ref_dose = refDose
196		)
197		}
198
199		## return it together with the resulting distance and the quantiles
200	2x	return(list(
201	2x	model = ret,
202	2x	parameters = pars,
203	2x	quantiles = attr(targetRes, "quantiles"),
204	2x	required = cbind(lower, median, upper),
205	2x	distance = distance
206		))
207		}
208
209		# nolint end
210
211		#' Helper for Minimal Informative Unimodal Beta Distribution
212		#'
213		#' As defined in Neuenschwander et al (2008), this function computes the
214		#' parameters of the minimal informative unimodal beta distribution, given the
215		#' request that the p-quantile should be q, i.e. `X ~ Be(a, b)` with
216		#' `Pr(X <= q) = p`.
217		#'
218		#' @param p (`number`)\cr the probability.
219		#' @param q (`number`)\cr the quantile.
220		#' @return A list with the two resulting beta parameters `a` and `b`.
221		#'
222		#' @keywords internal
223		h_get_min_inf_beta <- function(p, q) {
224	3x	assert_probability(p, bounds_closed = FALSE)
225	3x	assert_probability(q, bounds_closed = FALSE)
226
227	3x	if (q > p) {
228	1x	list(
229	1x	a = log(p) / log(q),
230	1x	b = 1
231		)
232		} else {
233	2x	list(
234	2x	a = 1,
235	2x	b = log(1 - p) / log(1 - q)
236		)
237		}
238		}
239
240		# nolint start
241
242		##' Construct a minimally informative prior
243		##'
244		##' This function constructs a minimally informative prior, which is captured in
245		##' a \code{\linkS4class{LogisticNormal}} (or
246		##' \code{\linkS4class{LogisticLogNormal}}) object.
247		##'
248		##' Based on the proposal by Neuenschwander et al (2008, Statistics in
249		##' Medicine), a minimally informative prior distribution is constructed. The
250		##' required key input is the minimum (\eqn{d_{1}} in the notation of the
251		##' Appendix A.1 of that paper) and the maximum value (\eqn{d_{J}}) of the dose
252		##' grid supplied to this function. Then \code{threshmin} is the probability
253		##' threshold \eqn{q_{1}}, such that any probability of DLT larger than
254		##' \eqn{q_{1}} has only 5% probability. Therefore \eqn{q_{1}} is the 95%
255		##' quantile of the beta distribution and hence \eqn{p_{1} = 0.95}. Likewise,
256		##' \code{threshmax} is the probability threshold \eqn{q_{J}}, such that any
257		##' probability of DLT smaller than \eqn{q_{J}} has only 5% probability
258		##' (\eqn{p_{J} = 0.05}). The probabilities \eqn{1 - p_{1}} and \eqn{p_{J}} can be
259		##' controlled with the arguments \code{probmin} and \code{probmax}, respectively.
260		##' Subsequently, for all doses supplied in the
261		##' \code{dosegrid} argument, beta distributions are set up from the assumption
262		##' that the prior medians are linear in log-dose on the logit scale, and
263		##' \code{\link{Quantiles2LogisticNormal}} is used to transform the resulting
264		##' quantiles into an approximating \code{\linkS4class{LogisticNormal}} (or
265		##' \code{\linkS4class{LogisticLogNormal}}) model. Note that the reference dose
266		##' is not required for these computations.
267		##'
268		##' @param dosegrid the dose grid
269		##' @param refDose the reference dose
270		##' @param threshmin Any toxicity probability above this threshold would
271		##' be very unlikely (see \code{probmin}) at the minimum dose (default: 0.2)
272		##' @param threshmax Any toxicity probability below this threshold would
273		##' be very unlikely (see \code{probmax}) at the maximum dose (default: 0.3)
274		##' @param probmin the prior probability of exceeding \code{threshmin} at the
275		##' minimum dose (default: 0.05)
276		##' @param probmax the prior probability of being below \code{threshmax} at the
277		##' maximum dose (default: 0.05)
278		##' @param \dots additional arguments for computations, see
279		##' \code{\link{Quantiles2LogisticNormal}}, e.g. \code{refDose} and
280		##' \code{logNormal=TRUE} to obtain a minimal informative log normal prior.
281		##' @return see \code{\link{Quantiles2LogisticNormal}}
282		##'
283		##' @example examples/MinimalInformative.R
284		##' @export
285		##' @keywords programming
286		MinimalInformative <- function(dosegrid,
287		refDose,
288		threshmin = 0.2,
289		threshmax = 0.3,
290		probmin = 0.05,
291		probmax = 0.05,
292		...) {
293		## extracts and checks
294	!	nDoses <- length(dosegrid)
295
296	!	assert_probability(threshmin, bounds_closed = FALSE)
297	!	assert_probability(threshmax, bounds_closed = FALSE)
298	!	assert_probability(probmin, bounds_closed = FALSE)
299	!	assert_probability(probmax, bounds_closed = FALSE)
300	!	stopifnot(
301	!	!is.unsorted(dosegrid, strictly = TRUE)
302		)
303	!	xmin <- dosegrid[1]
304	!	xmax <- dosegrid[nDoses]
305
306		## derive the beta distributions at the lowest and highest dose
307	!	betaAtMin <- h_get_min_inf_beta(
308	!	q = threshmin,
309	!	p = 1 - probmin
310		)
311	!	betaAtMax <- h_get_min_inf_beta(
312	!	q = threshmax,
313	!	p = probmax
314		)
315
316		## get the medians of those beta distributions
317	!	medianMin <- with(
318	!	betaAtMin,
319	!	qbeta(p = 0.5, a, b)
320		)
321	!	medianMax <- with(
322	!	betaAtMax,
323	!	qbeta(p = 0.5, a, b)
324		)
325
326		## now determine the medians of all beta distributions
327	!	beta <- (logit(medianMax) - logit(medianMin)) / (log(xmax) - log(xmin))
328	!	alpha <- logit(medianMax) - beta * log(xmax / refDose)
329	!	medianDosegrid <- plogis(alpha + beta * log(dosegrid / refDose))
330
331		## finally for all doses calculate 95% credible interval bounds
332		## (lower and upper)
333	!	lower <- upper <- dosegrid
334	!	for (i in seq_along(dosegrid))
335		{
336		## get min inf beta distribution
337	!	thisMinBeta <- h_get_min_inf_beta(
338	!	p = 0.5,
339	!	q = medianDosegrid[i]
340		)
341
342		## derive required quantiles
343	!	lower[i] <- with(
344	!	thisMinBeta,
345	!	qbeta(p = 0.025, a, b)
346		)
347	!	upper[i] <- with(
348	!	thisMinBeta,
349	!	qbeta(p = 0.975, a, b)
350		)
351		}
352
353		## now go to Quantiles2LogisticNormal
354	!	Quantiles2LogisticNormal(
355	!	dosegrid = dosegrid,
356	!	refDose = refDose,
357	!	lower = lower,
358	!	median = medianDosegrid,
359	!	upper = upper,
360	!	level = 0.95,
361		...
362		)
363		}
364
365		# nolint end

1		#' Format a `doseGrid` for Printing
2		#'
3		#' @param grid (`numeric`)\cr the dose grid
4		#' @param units (`character`)\cr The units in which the values in `doseGrid` are
5		#' measured. Appended to each value in `doseGrid` when `knit_print`ed. The
6		#' default, `NA`, omits the units.
7		#' @return A character string containing the formatted dose grid. If the grid
8		#' is `c(1, 2, 3)` and `units` is `"mg"`, the returned value is `"1 mg, 2 mg and 3 mg"`.
9		#' @keywords internal
10		h_get_formatted_dosegrid <- function(grid, units = NA) {
11	28x	assert_numeric(grid, lower = 0, min.len = 2, unique = TRUE, finite = TRUE, sorted = TRUE, any.missing = FALSE)
12	28x	assert_character(units, len = 1)
13
14	28x	n <- length(grid)
15	28x	if (is.na(units)) {
16	28x	units <- ""
17		} else {
18	!	units <- paste0(" ", units)
19		}
20	28x	paste0(
21	28x	paste(
22	28x	lapply(grid[1:(n - 1)], paste0, sep = units),
23	28x	collapse = ", "
24		),
25	28x	" and ",
26	28x	grid[n],
27	28x	paste0(units, ".")
28		)
29		}
30
31		#' Set Column Headers in Custom `knit_print` Methods
32		#'
33		#' This is a helper method used `knit_print` for `crmPack` classes.
34		#'
35		#' @param x (`ANY`)\cr object that will be printed
36		#' @param param (`list`)\cr A list of the `...` parameters passed to `knit_print`
37		#' @param summarise (`flag`)\cr Is the object to be summarised (default) or listed?
38		#' @return A character vector of column names.
39		#' @noRd
40		h_knit_print_set_headers <- function(x, param, summarise, ...) {
41	25x	UseMethod("h_knit_print_set_headers")
42		}
43
44		#' @description `r lifecycle::badge("experimental")`
45		#' @rdname knit_print_set_headers
46		#' @noRd
47		h_knit_print_set_headers.GeneralData <- function(x, param, summarise, ...) {
48	10x	if (!("col.names" %in% names(param))) {
49	10x	if (summarise == "none") {
50	8x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "DLT?")
51	2x	} else if (summarise == "dose") {
52	1x	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
53		} else {
54	1x	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
55		}
56		}
57	10x	param
58		}
59
60		#' @description `r lifecycle::badge("experimental")`
61		#' @rdname knit_print_set_headers
62		#' @noRd
63		h_knit_print_set_headers.DataDA <- function(x, param, summarise, ...) {
64	3x	if (!("col.names" %in% names(param))) {
65	3x	if (summarise == "none") {
66	3x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
67	!	} else if (summarise == "dose") {
68	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
69		} else {
70	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
71		}
72		}
73	3x	param
74		}
75
76		#' @description `r lifecycle::badge("experimental")`
77		#' @rdname knit_print_set_headers
78		#' @noRd
79		h_knit_print_set_headers.DataGrouped <- function(x, param, summarise, ...) {
80	3x	if (!("col.names" %in% names(param))) {
81	3x	if (summarise == "none") {
82	3x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Group", "Tox")
83	!	} else if (summarise == "dose") {
84	!	param[["col.names"]] <- c("Dose", "Group", "Evaluable", "With Toxicities")
85		} else {
86	!	param[["col.names"]] <- c("Cohort", "Group", "Evaluable", "With Toxicities")
87		}
88		}
89	3x	param
90		}
91
92		#' @description `r lifecycle::badge("experimental")`
93		#' @rdname knit_print_set_headers
94		#' @noRd
95		h_knit_print_set_headers.DataParts <- function(x, param, summarise, ...) {
96	3x	if (!("col.names" %in% names(param))) {
97	3x	if (summarise == "none") {
98	3x	param[["col.names"]] <- c("ID", "Part", "Cohort", "Dose", "Tox")
99	!	} else if (summarise == "dose") {
100	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
101		} else {
102	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
103		}
104		}
105	3x	param
106		}
107
108		#' @description `r lifecycle::badge("experimental")`
109		#' @noRd
110		h_knit_print_set_headers.DataOrdinal <- function(x, param, summarise, ...) {
111	3x	if (!("col.names" %in% names(param))) {
112	3x	if (summarise == "none") {
113	3x	param[["col.names"]] <- c("ID", "Cohort", "Dose", paste0("Cat", 0:(length(x@yCategories) - 1)))
114	!	} else if (summarise == "dose") {
115	!	param[["col.names"]] <- c("Dose", "Evaluable", names(x@yCategories))
116		} else {
117	!	param[["col.names"]] <- c("Cohort", "Evaluable", names(x@yCategories))
118		}
119		}
120	3x	param
121		}
122
123		#' @description `r lifecycle::badge("experimental")`
124		#' @rdname knit_print_set_headers
125		#' @noRd
126		h_knit_print_set_headers.DataDual <- function(x, param, summarise, ...) {
127	3x	if (!("col.names" %in% names(param))) {
128	3x	if (summarise == "none") {
129	3x	param[["col.names"]] <- c("ID", "Cohort", "Dose", "Tox", "W")
130	!	} else if (summarise == "dose") {
131	!	param[["col.names"]] <- c("Dose", "Evaluable", "With Toxicities")
132		} else {
133	!	param[["col.names"]] <- c("Cohort", "Evaluable", "With Toxicities")
134		}
135		}
136	3x	param
137		}
138
139		#' Select Columns to Print in Custom `knit_print` Methods
140		#'
141		#' This is a helper method used `knit_print` for `crmPack` classes.
142		#'
143		#' @param x (`ANY`)\cr object that will be printed
144		#' @param ... Not used at present.
145		#' @return A tidied version of `x`, containing only the selected columns.
146		#' @noRd
147		h_knit_print_select_columns <- function(x, ...) {
148	23x	UseMethod("h_knit_print_select_columns")
149		}
150
151		#' @description `r lifecycle::badge("experimental")`
152		#' @rdname knit_print_select_columns
153		#' @noRd
154		h_knit_print_select_columns.GeneralData <- function(x, ...) {
155	!	x %>%
156	!	tidy() %>%
157	!	dplyr::select("ID", "Cohort", "Dose", "Tox")
158		}
159
160		#' @description `r lifecycle::badge("experimental")`
161		#' @rdname knit_print_select_columns
162		#' @noRd
163		h_knit_print_select_columns.Data <- function(x, ...) {
164	8x	x %>%
165	8x	tidy() %>%
166	8x	dplyr::select("ID", "Cohort", "Dose", "Tox")
167		}
168
169		#' @description `r lifecycle::badge("experimental")`
170		#' @rdname knit_print_select_columns
171		#' @noRd
172		h_knit_print_select_columns.DataParts <- function(x, ...) {
173	3x	x %>%
174	3x	tidy() %>%
175	3x	dplyr::select("ID", "Part", "Cohort", "Dose", "Tox")
176		}
177
178		#' @description `r lifecycle::badge("experimental")`
179		#' @rdname knit_print_select_columns
180		#' @noRd
181		h_knit_print_select_columns.DataOrdinal <- function(x, ...) {
182	3x	x %>%
183	3x	tidy() %>%
184	3x	dplyr::select("ID", "Cohort", "Dose", tidyselect::starts_with("Cat"))
185		}
186
187		#' @description `r lifecycle::badge("experimental")`
188		#' @rdname knit_print_select_columns
189		#' @noRd
190		h_knit_print_select_columns.DataDA <- function(x, param, summarise, ...) {
191	3x	x %>%
192	3x	tidy() %>%
193	3x	dplyr::select("ID", "Cohort", "Dose", "Tox", "U", "T0", "TMax")
194		}
195
196		#' @description `r lifecycle::badge("experimental")`
197		#' @rdname knit_print_select_columns
198		#' @noRd
199		h_knit_print_select_columns.DataGrouped <- function(x, param, summarise, ...) {
200	3x	x %>%
201	3x	tidy() %>%
202	3x	dplyr::select("ID", "Cohort", "Dose", "Group", "Tox")
203		}
204
205		#' @description `r lifecycle::badge("experimental")`
206		#' @rdname knit_print_select_columns
207		#' @noRd
208		h_knit_print_select_columns.DataDual <- function(x, param, summarise, ...) {
209	3x	x %>%
210	3x	tidy() %>%
211	3x	dplyr::select("ID", "Cohort", "Dose", "Tox", "W")
212		}
213
214		#' Summarise a `Data` Object by Dose or Cohort for Display in Custom `knit_print` Methods
215		#'
216		#' This is a helper method used `knit_print` for `crmPack` classes.
217		#'
218		#' @param x (`ANY`)\cr object that will be printed
219		#' @param full_grid (`flag`)\cr Should the full grid be included or only those
220		#' doses with at least one evaluable participant?
221		#' @param ... Not used at present.
222		#' @return A tibble containing the summarised data
223		#' @noRd
224		h_knit_print_summarise <- function(x, summarise, full_grid, ...) {
225	2x	UseMethod("h_knit_print_summarise")
226		}
227
228		#' @description `r lifecycle::badge("experimental")`
229		#' @rdname knit_print_summarise
230		#' @noRd
231		h_knit_print_summarise.GeneralData <- function(x, summarise, full_grid, ...) {
232	2x	xTidy <- x %>% tidy()
233	2x	xTidy <- xTidy %>%
234	2x	dplyr::group_by(.data[[stringr::str_to_title(summarise)]]) %>%
235	2x	dplyr::summarise(
236	2x	N = dplyr::n(),
237	2x	ToxCount = sum(Tox)
238		)
239	2x	if (full_grid && summarise == "dose") {
240	!	xTidy <- xTidy %>%
241	!	tidyr::complete(
242	!	Dose = x@doseGrid,
243	!	fill = list(ToxCount = 0, N = 0)
244		)
245		}
246	2x	xTidy
247		}
248
249		#' @description `r lifecycle::badge("experimental")`
250		#' @rdname knit_print_summarise
251		#' @noRd
252		h_knit_print_summarise.DataOrdinal <- function(x, summarise, full_grid, ...) {
253	!	xTidy <- x %>% tidy()
254	!	xTidy <- xTidy %>%
255	!	dplyr::group_by(.data$Dose) %>%
256	!	dplyr::summarise(
257	!	N = dplyr::n(),
258	!	dplyr::across(tidyselect::starts_with("Cat"), sum)
259		)
260	!	if (full_grid && summarise == "dose") {
261	!	replace_list <- as.list(
262	!	c(
263	!	"N",
264	!	names(xTidy)[which(stringr::str_detect(names(xTidy), "Cat\\d+"))]
265		)
266		)
267		# Create a list whose names are the columns in which we need to replace NAs
268		# and whose values are 0
269	!	names(replace_list) <- sapply(replace_list, \(x) x)
270	!	replace_list <- lapply(replace_list, \(x) 0)
271		# Expand the tibble and do the replacement
272	!	xTidy <- tidyr::expand_grid(Dose = x@doseGrid) %>%
273	!	dplyr::left_join(xTidy, by = "Dose") %>%
274	!	tidyr::replace_na(replace_list)
275		}
276	!	xTidy
277		}
278
279		#' @description `r lifecycle::badge("experimental")`
280		#' @rdname knit_print_summarise
281		#' @noRd
282		h_knit_print_summarise.DataGrouped <- function(x, summarise, full_grid, ...) {
283	!	xTidy <- x %>% tidy()
284	!	xTidy <- xTidy %>%
285	!	dplyr::group_by(.data[[stringr::str_to_title(summarise)]], .data$Group) %>%
286	!	dplyr::summarise(
287	!	N = dplyr::n(),
288	!	ToxCount = sum(Tox)
289		)
290	!	if (full_grid && summarise == "dose") {
291	!	xTidy <- tidyr::expand_grid(
292	!	Dose = x@doseGrid,
293	!	Group = c("mono", "combo")
294		) %>%
295	!	dplyr::left_join(xTidy, by = c("Dose", "Group")) %>%
296	!	tidyr::replace_na(list(N = 0, ToxCount = 0))
297		}
298	!	xTidy
299		}
300
301		#' Print a `GeneralData` Object in a Markdown or Quarto Chunk
302		#'
303		#' @param labels (`character`)\cr How to describe the participants in the trial.
304		#' See Usage Notes below.
305		#' @param full_grid (`flag`)\cr Should the full dose grid appear in the output table
306		#' or simply those doses for whom at least one evaluable participant is available?
307		#' Ignored unless `summarise == "dose"`.
308		#' @param summarise (`character`)\cr How to summarise the observed data. The default,
309		#' `"none"`, lists observed data at the participant level. `"dose"` presents
310		#' participant counts by dose and `"cohort"` by cohort.
311		#' @param summarize (`character`)\cr Synonym for `summarise`
312		#' @param format_func (`function`)\cr The function used to format the participant table.
313		#' The default applies no formatting. Obvious alternatives include `kableExtra::kable_styling`.
314		#' @param ... passed to [knitr::kable()]
315		#' @section Usage Notes:
316		#' `labels` describes the trial's participants.
317		#'
318		#' It should be a character vector of length 1 or 2. If of length 2, the first
319		#' element describes a single participant and the second describes all other
320		#' situations. If of length 1, the character `s` is appended to the value
321		#' when the number of participants is not 1.
322		#' The default values of `col.names` and `caption` vary depending on the summary
323		#' requested. The default values can be overridden by passing `col.names` and
324		#' `caption` in the function call.
325		#'
326		#' @inheritParams h_get_formatted_dosegrid
327		#' @export
328		#' @rdname knit_print
329		knit_print.GeneralData <- function(
330		x, ..., asis = TRUE,
331		labels = c("participant", "participants"),
332		full_grid = FALSE,
333		summarise = c("none", "dose", "cohort"),
334		summarize = summarise,
335		units = NA,
336		format_func = function(x) x) {
337		# Validate
338	39x	assert_character(labels, max.len = 2, any.missing = FALSE)
339	39x	assert_flag(asis)
340	25x	assert_flag(full_grid)
341	25x	assert_function(format_func)
342	25x	summarise <- match.arg(summarise)
343	25x	summarize <- match.arg(summarize)
344
345	25x	if (is.na(summarise) \|\| is.null(summarise)) {
346	!	summarise <- summarize
347		}
348	25x	assert_choice(summarise, c("none", "dose", "cohort"))
349		# Initialise
350	25x	if (length(labels) == 1) {
351	!	labels[2] <- paste0(labels[1], "s")
352		}
353	25x	param <- list(...)
354
355		# Execute
356	25x	param <- h_knit_print_set_headers(x, param, summarise, ...)
357	25x	if (summarise == "none") {
358	23x	if (!("caption" %in% names(param))) {
359	23x	param[["caption"]] <- paste("Evaluable", labels[2], "to-date")
360		}
361	23x	xTidy <- h_knit_print_select_columns(x)
362		} else {
363	2x	xTidy <- h_knit_print_summarise(x, summarise, full_grid)
364	2x	if (!("caption" %in% names(param))) {
365	2x	param[["caption"]] <- paste0("Summarised by ", summarise)
366		}
367		}
368	25x	param[["x"]] <- xTidy
369	25x	rv <- if (length(x@x) > 0) {
370	25x	paste((do.call(knitr::kable, param)) %>% format_func(), collapse = "\n")
371		} else {
372	!	paste("No", labels[2], "are yet evaluable.\n\n")
373		}
374	25x	rv <- paste0(
375	25x	rv,
376	25x	paste0(
377	25x	"\n\nThe dose grid is ",
378	25x	h_get_formatted_dosegrid(
379	25x	grid = x@doseGrid,
380	25x	units = units
381		),
382		""
383		),
384	25x	collpase = "<br>"
385		)
386	25x	if (asis) {
387	18x	rv <- knitr::asis_output(rv)
388		}
389	25x	rv
390		}
391
392		#' @export
393		#' @rdname knit_print
394		knit_print.DataParts <- function(
395		x, ..., asis = TRUE,
396		labels = c("participant", "participants"),
397		full_grid = FALSE,
398		summarise = c("none", "dose", "cohort"),
399		summarize = summarise,
400		units = NA,
401		format_func = function(x) x) {
402	5x	rv <- NextMethod()
403	3x	rv <- paste0(
404	3x	rv,
405	3x	paste0(
406	3x	"\n\nThe part 1 ladder is ",
407	3x	h_get_formatted_dosegrid(x@part1Ladder, units)
408		),
409	3x	paste0("\n\nThe next part is Part ", x@nextPart, ".")
410		)
411	3x	if (asis) {
412	2x	rv <- knitr::asis_output(rv)
413		}
414	3x	rv
415		}

1		#' @include helpers.R
2		#' @include Data-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# GeneralData-class ----
7
8		#' `GeneralData`
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' [`GeneralData`] is a class for general data input.
13		#'
14		#' @slot ID (`integer`)\cr unique patient IDs.
15		#' @slot cohort (`integer`)\cr the cohort (non-negative sorted) indices.
16		#' @slot nObs (`integer`)\cr number of observations, a single value.
17		#'
18		#' @aliases GeneralData
19		#' @export
20		#'
21		.GeneralData <- setClass(
22		Class = "GeneralData",
23		slots = c(
24		ID = "integer",
25		cohort = "integer",
26		nObs = "integer"
27		),
28		prototype = prototype(
29		ID = integer(),
30		cohort = integer(),
31		nObs = 0L
32		),
33		contains = "CrmPackClass",
34		validity = v_general_data
35		)
36
37		## default constructor ----
38
39		#' @rdname GeneralData-class
40		#' @note Typically, end users will not use the `.DefaultDataGeneral()` function.
41		#' @export
42		.DefaultDataGeneral <- function() {
43	!	stop(paste0("Class DataGeneral cannot be instantiated directly. Please use one of its subclasses instead."))
44		}
45
46		# Data ----
47
48		## class ----
49
50		#' `Data`
51		#'
52		#' @description `r lifecycle::badge("stable")`
53		#'
54		#' [`Data`] is a class for the data input.
55		#' It inherits from [`GeneralData`].
56		#'
57		#' @slot x (`numeric`)\cr the doses for the patients.
58		#' @slot y (`integer`)\cr the vector of toxicity events (0 or 1 integers).
59		#' @slot doseGrid (`numeric`)\cr the vector of all possible doses (sorted),
60		#' i.e. the dose grid.
61		#' @slot nGrid (`integer`)\cr number of gridpoints.
62		#' @slot xLevel (`integer`)\cr the levels for the doses the patients have been given,
63		#' w.r.t `doseGrid`.
64		#' @slot placebo (`logical`)\cr if `TRUE` the first dose level
65		#' in the `doseGrid`is considered as PLACEBO.
66		#'
67		#' @aliases Data
68		#' @export
69		#'
70		.Data <- setClass(
71		Class = "Data",
72		contains = "GeneralData",
73		slots = c(
74		x = "numeric",
75		y = "integer",
76		doseGrid = "numeric",
77		nGrid = "integer",
78		xLevel = "integer",
79		placebo = "logical"
80		),
81		prototype = prototype(
82		x = numeric(),
83		y = integer(),
84		doseGrid = numeric(),
85		nGrid = 0L,
86		xLevel = integer(),
87		placebo = FALSE
88		),
89		validity = v_data
90		)
91
92		## constructor ----
93
94		#' @rdname Data-class
95		#'
96		#' @details The `cohort` can be missing if and only if `placebo` is equal to
97		#' `FALSE`.
98		#'
99		#' @note `ID` and `cohort` can be missing. Then a message will be issued
100		#' and the variables will be filled with default IDs and best guesses cohort,
101		#' i.e. a sorted (in ascending order) sequence of values from `{1, 2, ...}`.
102		#'
103		#' @param x (`numeric`)\cr the doses for the patients.
104		#' @param y (`integer`)\cr the vector of toxicity events (0 or 1).
105		#' You can also supply `numeric` vectors, but these will then be converted to
106		#' `integer` internally.
107		#' @param ID (`integer`)\cr unique patient IDs.
108		#' You can also supply `numeric` vectors, but these will then be converted to
109		#' `integer` internally.
110		#' @param cohort (`integer`)\cr the cohort (non-negative sorted) indices.
111		#' You can also supply `numeric` vectors, but these will then be converted to
112		#' `integer` internally.
113		#' @param doseGrid (`numeric`)\cr all possible doses.
114		#' @param placebo (`flag`)\cr if `TRUE` the first dose level
115		#' in the `doseGrid` is considered as placebo.
116		#' @param ... not used.
117		#'
118		#' @export
119		#' @example examples/Data-class.R
120		#'
121		Data <- function(x = numeric(),
122		y = integer(),
123		ID = integer(),
124		cohort = integer(),
125		doseGrid = numeric(),
126		placebo = FALSE,
127		...) {
128	862x	assert_numeric(x)
129	862x	assert_integerish(y, lower = 0, upper = 1, any.missing = FALSE)
130	862x	assert_integerish(ID, unique = TRUE, any.missing = FALSE)
131	862x	assert_integerish(cohort)
132	862x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
133	862x	assert_flag(placebo)
134
135	862x	doseGrid <- sort(doseGrid)
136	862x	assert_subset(x, doseGrid)
137
138	862x	if (length(ID) == 0 && length(x) > 0) {
139	1x	message("Used default patient IDs!")
140	1x	ID <- seq_along(x)
141		} else {
142	861x	assert_integerish(ID, unique = TRUE)
143		}
144
145	862x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
146	1x	message("Used best guess cohort indices!")
147		# This is just assuming that consecutive patients
148		# in the data set are in the same cohort if they
149		# have the same dose. Note that this could be wrong,
150		# if two subsequent cohorts are at the same dose.
151	1x	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
152		} else {
153	861x	assert_integerish(cohort)
154		}
155
156	862x	.Data(
157	862x	x = as.numeric(x),
158	862x	y = as.integer(y),
159	862x	ID = as.integer(ID),
160	862x	cohort = as.integer(cohort),
161	862x	doseGrid = as.numeric(doseGrid),
162	862x	nObs = length(x),
163	862x	nGrid = length(doseGrid),
164	862x	xLevel = match_within_tolerance(x, doseGrid),
165	862x	placebo = placebo
166		)
167		}
168
169		## default constructor ----
170
171		#' @rdname Data-class
172		#' @note Typically, end users will not use the `.DefaultData()` function.
173		#' @export
174		.DefaultData <- function() {
175	12x	Data(
176	12x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
177	12x	ID = 1L:3L,
178	12x	cohort = 1L:3L,
179	12x	x = c(1, 3, 5),
180	12x	y = rep(0L, 3)
181		)
182		}
183
184		# DataDual ----
185
186		## class ----
187
188		#' `DataDual`
189		#'
190		#' @description `r lifecycle::badge("stable")`
191		#'
192		#' [`DataDual`] is a class for the dual endpoint data.
193		#' It inherits from [`Data`] and it contains additional biomarker information.
194		#'
195		#' @slot w (`numeric`)\cr the continuous vector of biomarker values.
196		#'
197		#' @aliases DataDual
198		#' @export
199		#'
200		.DataDual <- setClass(
201		Class = "DataDual",
202		slots = c(w = "numeric"),
203		prototype = prototype(w = numeric()),
204		contains = "Data",
205		validity = v_data_dual
206		)
207
208		## constructor ----
209
210		#' @rdname DataDual-class
211		#'
212		#' @param w (`numeric`)\cr the continuous vector of biomarker values.
213		#' @param ... parameters passed to [Data()].
214		#'
215		#' @export
216		#' @example examples/Data-class-DataDual.R
217		#'
218		DataDual <- function(w = numeric(),
219		...) {
220	171x	d <- Data(...)
221	171x	.DataDual(d, w = w)
222		}
223
224
225		## default constructor ----
226
227		#' @rdname DataDual-class
228		#' @note Typically, end users will not use the `.DefaultDataDual()` function.
229		#' @export
230		.DefaultDataDual <- function() {
231	5x	set.seed(1230)
232	5x	DataDual(
233	5x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
234	5x	y = c(0, 0, 0, 0, 0, 0, 1, 0),
235	5x	w = rnorm(8),
236	5x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
237	5x	ID = 1L:8L,
238	5x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
239		)
240		}
241
242		# DataParts ----
243
244		## class ----
245
246		#' `DataParts`
247		#'
248		#' @description `r lifecycle::badge("stable")`
249		#'
250		#' [`DataParts`] is a class for the data with two study parts.
251		#' It inherits from [`Data`] and it contains additional information
252		#' on the two study parts.
253		#'
254		#' @slot part (`integer`)\cr which part does each of the patients belong to?
255		#' @slot nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
256		#' @slot part1Ladder (`numeric`)\cr what is the escalation ladder for
257		#' part 1? This shall be an ordered subset of the `doseGrid`.
258		#'
259		#' @aliases DataParts
260		#' @export
261		#'
262		.DataParts <- setClass(
263		Class = "DataParts",
264		slots = c(
265		part = "integer",
266		nextPart = "integer",
267		part1Ladder = "numeric"
268		),
269		prototype = prototype(
270		part = integer(),
271		nextPart = 1L,
272		part1Ladder = numeric()
273		),
274		contains = "Data",
275		validity = v_data_parts
276		)
277
278		## constructor ----
279
280		#' @rdname DataParts-class
281		#'
282		#' @param part (`integer`)\cr which part does each of the patients belong to?
283		#' @param nextPart (`count`)\cr what is the part for the next cohort (1 or 2)?
284		#' @param part1Ladder (`numeric`)\cr what is the escalation ladder for part 1?
285		#' This shall be an ordered subset of the `doseGrid`.
286		#' @param ... parameters passed to [Data()].
287		#'
288		#' @export
289		#' @example examples/Data-class-DataParts.R
290		#'
291		DataParts <- function(part = integer(),
292		nextPart = 1L,
293		part1Ladder = numeric(),
294		...) {
295	25x	d <- Data(...)
296	25x	.DataParts(
297	25x	d,
298	25x	part = part,
299	25x	nextPart = nextPart,
300	25x	part1Ladder = part1Ladder
301		)
302		}
303
304		## default constructor ----
305
306		#' @rdname DataParts-class
307		#' @note Typically, end users will not use the `.DefaultDataParts()` function.
308		#' @export
309		.DefaultDataParts <- function() {
310	4x	DataParts(
311	4x	x = c(0.1, 0.5, 1.5),
312	4x	y = c(0, 0, 0),
313	4x	ID = 1:3,
314	4x	cohort = 1:3,
315	4x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
316	4x	part = c(1L, 1L, 1L),
317	4x	nextPart = 1L,
318	4x	part1Ladder = c(0.1, 0.5, 1.5, 3, 6, 10)
319		)
320		}
321
322
323		# DataMixture ----
324
325		## class ----
326
327		#' `DataMixture`
328		#'
329		#' @description `r lifecycle::badge("stable")`
330		#'
331		#' [`DataMixture`] is a class for the data with mixture sharing.
332		#' It inherits from [`Data`] and it contains additional information
333		#' on the mixture sharing.
334		#'
335		#' @slot xshare (`numeric`)\cr the doses for the share patients.
336		#' @slot yshare (`integer`)\cr the vector of toxicity events (0 or 1)
337		#' for the share patients.
338		#' @slot nObsshare (`count`)\cr number of share patients.
339		#'
340		#' @aliases DataMixture
341		#' @export
342		#'
343		.DataMixture <- setClass(
344		Class = "DataMixture",
345		slots = c(
346		xshare = "numeric",
347		yshare = "integer",
348		nObsshare = "integer"
349		),
350		prototype = prototype(
351		xshare = numeric(),
352		yshare = integer(),
353		nObsshare = 0L
354		),
355		contains = "Data",
356		validity = v_data_mixture
357		)
358
359		## constructor ----
360
361		#' @rdname DataMixture-class
362		#'
363		#' @param xshare (`numeric`)\cr the doses for the share patients.
364		#' @param yshare (`integer`)\cr the vector of toxicity events (0 or 1)
365		#' for the share patients. You can also supply `numeric` vectors,
366		#' but these will then be converted to `integer` internally.
367		#' @param ... parameters passed to [Data()].
368		#'
369		#' @export
370		#' @example examples/Data-class-DataMixture.R
371		#'
372		DataMixture <- function(xshare = numeric(),
373		yshare = integer(),
374		...) {
375	7x	d <- Data(...)
376	7x	assert_integerish(yshare)
377	7x	assert_numeric(xshare)
378	7x	.DataMixture(
379	7x	d,
380	7x	xshare = as.numeric(xshare),
381	7x	yshare = as.integer(yshare),
382	7x	nObsshare = length(xshare)
383		)
384		}
385
386		## default constructor ----
387
388		#' @rdname DataMixture-class
389		#' @note Typically, end users will not use the `.DefaultDataMixture()` function.
390		#' @export
391		.DefaultDataMixture <- function() {
392	5x	DataMixture(
393	5x	xshare = c(12, 14, 16, 18.0),
394	5x	yshare = c(0L, 1L, 1L, 1L),
395	5x	nObsshare = 4L,
396	5x	x = c(0.1, 0.5, 1.5),
397	5x	y = c(0, 0, 0),
398	5x	ID = 1L:3L,
399	5x	cohort = 1L:3L,
400	5x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2))
401		)
402		}
403
404
405		# DataDA ----
406
407		## class ----
408
409		#' `DataDA`
410		#'
411		#' @description `r lifecycle::badge("stable")`
412		#'
413		#' [`DataDA`] is a class for the time-to-DLT augmented data.
414		#' It inherits from [`Data`] and it contains additional DLT free survival times.
415		#'
416		#' @note `survival time` here refers to the time period for which the subject
417		#' did not experience any DLT, and is not referring to deaths.
418		#'
419		#' @slot u (`numeric`)\cr the continuous vector of DLT free survival times.
420		#' @slot t0 (`numeric`)\cr time of initial dosing for each patient.
421		#' Non-negative values sorted in ascending order.
422		#' @slot Tmax (`number`)\cr the DLT observation period.
423		#'
424		#' @aliases DataDA
425		#' @export
426		#'
427		.DataDA <- setClass(
428		Class = "DataDA",
429		slots = c(
430		u = "numeric",
431		t0 = "numeric",
432		Tmax = "numeric"
433		),
434		prototype = prototype(
435		u = numeric(),
436		t0 = numeric(),
437		Tmax = 0 + .Machine$double.xmin
438		),
439		contains = "Data",
440		validity = v_data_da
441		)
442
443		## constructor ----
444
445		#' @rdname DataDA-class
446		#'
447		#' @param u (`numeric`)\cr the continuous vector of DLT free survival times.
448		#' @param t0 (`numeric`)\cr time of initial dosing for each patient.
449		#' Non-negative values sorted in ascending order.
450		#' Default to vector of 0s of length equal to length of `u`.
451		#' @param Tmax (`number`)\cr the DLT observation period.
452		#' @param ... parameters passed to [Data()].
453		#'
454		#' @export
455		#' @example examples/Data-class-DataDA.R
456		#'
457		DataDA <- function(u = numeric(),
458		t0 = numeric(length(u)),
459		Tmax = 0 + .Machine$double.xmin,
460		...) {
461	26x	d <- Data(...)
462	26x	.DataDA(
463	26x	d,
464	26x	u = as.numeric(u),
465	26x	t0 = as.numeric(t0),
466	26x	Tmax = as.numeric(Tmax)
467		)
468		}
469
470		## default constructor ----
471
472		#' @rdname DataDA-class
473		#' @note Typically, end users will not use the `.DefaultDataDA()` function.
474		#' @export
475		.DefaultDataDA <- function() {
476	5x	DataDA(
477	5x	u = c(42, 30, 15, 5, 20, 25, 30, 60),
478	5x	t0 = c(0, 15, 30, 40, 55, 70, 75, 85),
479	5x	Tmax = 60,
480	5x	x = c(0.1, 0.5, 1.5, 3, 6, 10, 10, 10),
481	5x	y = c(0, 0, 1, 1, 0, 0, 1, 0),
482	5x	doseGrid = c(0.1, 0.5, 1.5, 3, 6, seq(from = 10, to = 80, by = 2)),
483	5x	ID = 1L:8L,
484	5x	cohort = as.integer(c(1, 2, 3, 4, 5, 6, 6, 6))
485		)
486		}
487
488		# DataOrdinal ----
489
490		## class ----
491
492		#' `DataOrdinal`
493		#'
494		#' @description `r lifecycle::badge("experimental")`
495		#'
496		#' [`DataOrdinal`] is a class for ordinal toxicity data.
497		#' It inherits from [`GeneralData`] and it describes toxicity responses on an
498		#' ordinal rather than binary scale.
499		#'
500		#' @note This class has been implemented as a sibling of the existing `Data` class
501		#' (rather than as a parent or child) to minimise the risk of unintended side
502		#' effects on existing classes and methods.
503		#'
504		#' The default setting for the `yCategories` slot replicates the behaviour
505		#' of the existing `Data` class.
506		#'
507		#' @aliases DataOrdinal
508		#' @export
509		.DataOrdinal <- setClass(
510		Class = "DataOrdinal",
511		contains = "GeneralData",
512		slots = c(
513		x = "numeric",
514		y = "integer",
515		doseGrid = "numeric",
516		nGrid = "integer",
517		xLevel = "integer",
518		yCategories = "integer",
519		placebo = "logical"
520		),
521		prototype = prototype(
522		x = numeric(),
523		y = integer(),
524		doseGrid = numeric(),
525		nGrid = 0L,
526		xLevel = integer(),
527		yCategories = c("No DLT" = 0L, "DLT" = 1L),
528		placebo = FALSE
529		),
530		validity = v_data_ordinal
531		)
532
533		## constructor ----
534
535		#' @rdname DataOrdinal-class
536		#' @param yCategories (named `integer`)\cr the names and codes for the
537		#' toxicity categories used in the data. Category labels are taken from the
538		#' names of the vector. The names of the vector must be unique and its values
539		#' must be sorted and take the values 0, 1, 2, ...
540		#' @inheritParams Data
541		#' @inherit Data details note params
542		#' @example examples/Data-class-DataOrdinal.R
543		#' @export
544		DataOrdinal <- function(x = numeric(),
545		y = integer(),
546		ID = integer(),
547		cohort = integer(),
548		doseGrid = numeric(),
549		placebo = FALSE,
550		yCategories = c("No DLT" = 0L, "DLT" = 1L),
551		...) {
552	61x	assert_numeric(doseGrid, any.missing = FALSE, unique = TRUE)
553	61x	assert_integerish(
554	61x	yCategories,
555	61x	any.missing = FALSE,
556	61x	unique = TRUE,
557	61x	names = "unique",
558	61x	min.len = 2
559		)
560	61x	assert_flag(placebo)
561
562	61x	doseGrid <- as.numeric(sort(doseGrid))
563
564	61x	if (length(ID) == 0 && length(x) > 0) {
565	!	message("Used default patient IDs!")
566	!	ID <- seq_along(x)
567		} else {
568	61x	assert_integerish(ID, unique = TRUE)
569		}
570
571	61x	if (!placebo && length(cohort) == 0 && length(x) > 0) {
572	!	message("Used best guess cohort indices!")
573		# This is just assuming that consecutive patients
574		# in the data set are in the same cohort if they
575		# have the same dose. Note that this could be wrong,
576		# if two subsequent cohorts are at the same dose.
577	!	cohort <- as.integer(c(1, 1 + cumsum(diff(x) != 0)))
578		} else {
579	61x	assert_integerish(cohort)
580		}
581
582	61x	.DataOrdinal(
583	61x	x = as.numeric(x),
584	61x	y = as.integer(y),
585	61x	ID = as.integer(ID),
586	61x	cohort = as.integer(cohort),
587	61x	doseGrid = doseGrid,
588	61x	nObs = length(x),
589	61x	nGrid = length(doseGrid),
590	61x	xLevel = match_within_tolerance(x = x, table = doseGrid),
591	61x	placebo = placebo,
592	61x	yCategories = yCategories
593		)
594		}
595
596
597		## default constructor ----
598
599		#' @rdname DataOrdinal-class
600		#' @note Typically, end users will not use the `.DefaultDataOrdinal()` function.
601		#' @export
602		.DefaultDataOrdinal <- function() {
603	20x	DataOrdinal(
604	20x	x = c(10, 20, 30, 40, 50, 50, 50, 60, 60, 60),
605	20x	y = as.integer(c(0, 0, 0, 0, 0, 1, 0, 0, 1, 2)),
606	20x	ID = 1L:10L,
607	20x	cohort = as.integer(c(1:4, 5, 5, 5, 6, 6, 6)),
608	20x	doseGrid = c(seq(from = 10, to = 100, by = 10)),
609	20x	yCategories = c("No tox" = 0L, "Sub-tox AE" = 1L, "DLT" = 2L),
610	20x	placebo = FALSE
611		)
612		}
613
614		# DataGrouped ----
615
616		## class ----
617
618		#' `DataGrouped`
619		#'
620		#' @description `r lifecycle::badge("stable")`
621		#'
622		#' [`DataGrouped`] is a class for a two groups dose escalation data set,
623		#' comprised of a monotherapy (`mono`) and a combination therapy (`combo`)
624		#' arm. It inherits from [`Data`] and it contains the additional group information.
625		#'
626		#' @slot group (`factor`)\cr whether `mono` or `combo` was used.
627		#'
628		#' @aliases DataGrouped
629		#' @export
630		.DataGrouped <- setClass(
631		Class = "DataGrouped",
632		slots = c(
633		group = "factor"
634		),
635		prototype = prototype(
636		group = factor(levels = c("mono", "combo"))
637		),
638		contains = "Data",
639		validity = v_data_grouped
640		)
641
642		#' @rdname DataGrouped-class
643		#'
644		#' @param group (`factor` or `character`)\cr whether `mono` or `combo` was used.
645		#' If `character` then will be coerced to `factor` with the correct levels
646		#' internally.
647		#' @param ... parameters passed to [Data()].
648		#'
649		#' @export
650		#' @example examples/Data-class-DataGrouped.R
651		#'
652		DataGrouped <- function(group = character(),
653		...) {
654	80x	d <- Data(...)
655	80x	if (!is.factor(group)) {
656	80x	assert_character(group)
657	80x	assert_subset(group, choices = c("mono", "combo"))
658	80x	group <- factor(group, levels = c("mono", "combo"))
659		}
660	80x	.DataGrouped(
661	80x	d,
662	80x	group = group
663		)
664		}
665
666		## default constructor ----
667
668		#' @rdname DataGrouped-class
669		#' @note Typically, end users will not use the `.DefaultDataGrouped()` function.
670		#' @export
671		.DefaultDataGrouped <- function() {
672	6x	DataGrouped(
673	6x	group = c("mono", "mono", "combo"),
674	6x	x = c(1, 3, 5),
675	6x	y = c(0, 0, 0),
676	6x	ID = 1L:3L,
677	6x	cohort = 1L:3L,
678	6x	doseGrid = c(1, 3, 5, 10, 15, 20, 25, 40, 50, 80, 100),
679	6x	placebo = FALSE
680		)
681		}

1		#' Internal Helper Functions for Validation of [`GeneralData`] Objects
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' These functions are only used internally to validate the format of an input
6		#' [`GeneralData`] or inherited classes and therefore not exported.
7		#'
8		#' @name v_data_objects
9		#' @param object (`GeneralData`)\cr object to validate.
10		#' @return A `character` vector with the validation failure messages,
11		#' or `TRUE` in case validation passes.
12		NULL
13
14		#' @describeIn v_data_objects validates that the [`GeneralData`]
15		#' object contains unique `ID`, non-negative `cohort` indices and
16		#' `ID` and `cohort` vectors are of the same length `nObs`.
17		v_general_data <- function(object) {
18	2x	v <- Validate()
19		# In if clause so that below test_* won't fail.
20	2x	if (!test_int(object@nObs)) {
21	!	return("nObs must be of type integer of length 1")
22		}
23	2x	v$check(
24	2x	test_integer(object@ID, len = object@nObs, any.missing = FALSE, unique = TRUE, null.ok = TRUE),
25	2x	"ID must be of type integer and length nObs and unique"
26		)
27	2x	v$check(
28	2x	test_integer(object@cohort, lower = 0L, len = object@nObs, any.missing = FALSE, sorted = TRUE),
29	2x	"cohort must be of type integer and length nObs and contain non-negative, sorted values"
30		)
31	2x	v$result()
32		}
33
34		#' @describeIn v_data_objects helper function which verifies whether
35		#' the `dose` values are unique in each and every different `cohort`.
36		#' @param dose (`numeric`)\cr dose values.
37		#' @param cohort (`integer`)\cr cohort indices parallel to `doses`.
38		#' @return `TRUE` if `dose` is unique per `cohort`, otherwise `FALSE`.
39		h_doses_unique_per_cohort <- function(dose, cohort) {
40	1987x	assert_numeric(dose)
41	1987x	assert_integer(cohort)
42
43	1987x	num_doses_per_cohort <- tapply(
44	1987x	X = dose,
45	1987x	INDEX = cohort,
46	1987x	FUN = function(d) length(unique(d))
47		)
48	1987x	all(num_doses_per_cohort == 1L)
49		}
50
51		#' Helper Function performing validation Common to Data and DataOrdinal
52		#'
53		#' @rdname h_validate_common_data_slots
54		#' @param object (`Data` or `DataOrdinal`)\cr the object to be validated
55		#' @returns a `Validate` object containing the result of the validation
56		h_validate_common_data_slots <- function(object) {
57	1985x	v <- Validate()
58	1985x	v$check(
59	1985x	test_double(object@x, len = object@nObs, any.missing = FALSE),
60	1985x	"Doses vector x must be of type double and length nObs"
61		)
62	1985x	v$check(
63	1985x	test_double(object@doseGrid, len = object@nGrid, any.missing = FALSE, unique = TRUE, sorted = TRUE),
64	1985x	"doseGrid must be of type double and length nGrid and contain unique, sorted values"
65		)
66	1985x	v$check(
67	1985x	test_int(object@nGrid),
68	1985x	"Number of dose grid values nGrid must be scalar integer"
69		)
70	1985x	v$check(
71	1985x	test_integer(object@xLevel, len = object@nObs, any.missing = FALSE),
72	1985x	"Levels xLevel for the doses the patients have been given must be of type integer and length nObs"
73		)
74	1985x	v$check(
75	1985x	test_flag(object@placebo),
76	1985x	"The placebo flag must be scalar logical"
77		)
78	1985x	v$check(
79	1985x	test_subset(object@x, object@doseGrid),
80	1985x	"Dose values in x must be from doseGrid"
81		)
82	1985x	v$check(
83	1985x	h_all_equivalent(object@x, object@doseGrid[object@xLevel]),
84	1985x	"x must be equivalent to doseGrid[xLevel] (up to numerical tolerance)"
85		)
86	1985x	if (object@placebo) {
87	324x	is_placebo <- object@x == object@doseGrid[1]
88	324x	v$check(
89	324x	test_set_equal(object@cohort, object@cohort[!is_placebo]),
90	324x	"A cohort with only placebo is not allowed"
91		)
92	324x	v$check(
93	324x	h_doses_unique_per_cohort(dose = object@x[!is_placebo], cohort = object@cohort[!is_placebo]),
94	324x	"There must be only one dose level, other than placebo, per cohort"
95		)
96		} else {
97	1661x	v$check(
98	1661x	h_doses_unique_per_cohort(dose = object@x, cohort = object@cohort),
99	1661x	"There must be only one dose level per cohort"
100		)
101		}
102	1985x	v
103		}
104
105		#' @describeIn v_data_objects validates that the [`Data`] object contains
106		#' valid elements with respect to their types, dependency and length.
107		v_data <- function(object) {
108	4x	v <- h_validate_common_data_slots(object)
109	4x	v$check(
110	4x	test_integer(object@y, lower = 0, upper = 1, len = object@nObs, any.missing = FALSE),
111	4x	"DLT vector y must be nObs long and contain 0 or 1 integers only"
112		)
113
114	4x	v$result()
115		}
116
117		#' @describeIn v_data_objects validates that the [`DataDual`] object
118		#' contains valid biomarker vector with respect to its type and the length.
119		v_data_dual <- function(object) {
120	2x	v <- Validate()
121	2x	v$check(
122	2x	test_double(object@w, len = object@nObs, any.missing = FALSE),
123	2x	"Biomarker vector w must be of type double and length nObs"
124		)
125	2x	v$result()
126		}
127
128		#' @describeIn v_data_objects validates that the [`DataParts`] object
129		#' contains valid elements with respect to their types, dependency and length.
130		v_data_parts <- function(object) {
131	5x	v <- Validate()
132	5x	v$check(
133	5x	test_integer(object@part, lower = 1, upper = 2, len = object@nObs, any.missing = FALSE),
134	5x	"vector part must be nObs long and contain 1 or 2 integers only"
135		)
136	5x	v$check(
137	5x	test_int(object@nextPart, lower = 1, upper = 2),
138	5x	"nextPart must be integer scalar 1 or 2"
139		)
140	5x	v$check(
141	5x	test_numeric(object@part1Ladder, any.missing = FALSE, sorted = TRUE, unique = TRUE),
142	5x	"part1Ladder must be of type double and contain unique, sorted values"
143		)
144	5x	v$check(
145	5x	test_subset(object@part1Ladder, object@doseGrid),
146	5x	"part1Ladder must have all entries from doseGrid"
147		)
148	5x	v$result()
149		}
150
151		#' @describeIn v_data_objects validates that the [`DataMixture`] object
152		#' contains valid elements with respect to their types, dependency and length.
153		v_data_mixture <- function(object) {
154	5x	v <- Validate()
155
156		# In if clause so that below test_* won't fail.
157	5x	if (!test_int(object@nObsshare)) {
158	1x	return("nObsshare must be of type integer of length 1")
159		}
160	4x	v$check(
161	4x	test_numeric(object@xshare, len = object@nObsshare, any.missing = FALSE),
162	4x	"Dose vector xshare must be of type double and length nObsshare"
163		)
164	4x	v$check(
165	4x	test_integer(object@yshare, lower = 0, upper = 1, len = object@nObsshare, any.missing = FALSE),
166	4x	"DLT vector yshare must be nObsshare long and contain 0 or 1 integers only"
167		)
168	4x	v$check(
169	4x	test_subset(object@xshare, object@doseGrid),
170	4x	"Dose values in xshare must be from doseGrid"
171		)
172	4x	v$result()
173		}
174
175		#' @describeIn v_data_objects validates that the [`DataDA`] object
176		#' contains valid elements with respect to their types, dependency and length.
177		v_data_da <- function(object) {
178	4x	v <- Validate()
179		# In if clause so that below test_* won't fail.
180	4x	if (!(test_number(object@Tmax) && object@Tmax > 0)) {
181	1x	return("DLT window Tmax must be of type double of length 1 and greater than 0")
182		}
183	3x	v$check(
184	3x	test_numeric(object@u, upper = object@Tmax, len = object@nObs, any.missing = FALSE) &&
185	3x	all(object@u > 0),
186	3x	"u must be of type double, nObs length, non-negative and not greater than Tmax"
187		)
188	3x	v$check(
189	3x	test_numeric(object@t0, lower = 0, len = object@nObs, any.missing = FALSE, sorted = TRUE),
190	3x	"t0 must be of type double, nObs length, sorted non-negative"
191		)
192	3x	v$result()
193		}
194
195		#' @describeIn v_data_objects validates that the [`DataOrdinal`] object
196		#' contains valid elements with respect to their types, dependency and length.
197		v_data_ordinal <- function(object) {
198	8x	v <- h_validate_common_data_slots(object)
199	8x	v$check(
200	8x	test_integer(object@y, lower = 0, upper = length(object@yCategories) - 1, len = object@nObs, any.missing = FALSE),
201	8x	"DLT vector y must be nObs long and contain integers between 0 and k-1 only, where k is the length of the vector in the yCategories slot" # nolint
202		)
203	8x	v$check(
204	8x	length(unique(names(object@yCategories))) == length(names(object@yCategories)),
205	8x	"yCategory labels must be unique"
206		)
207	8x	v$result()
208		}
209
210		#' @describeIn v_data_objects validates that the [`DataGrouped`] object
211		#' contains valid group information.
212		v_data_grouped <- function(object) {
213	3x	v <- Validate()
214	3x	v$check(
215	3x	test_factor(
216	3x	object@group,
217	3x	levels = c("mono", "combo"),
218	3x	len = object@nObs,
219	3x	any.missing = FALSE
220		),
221	3x	"group must be factor with levels mono and combo of length nObs without missings"
222		)
223	3x	v$result()
224		}

1		#' @include helpers.R
2		NULL
3
4		#' Appending a Dummy Number for Selected Slots in Data
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#'
8		#' A helper function that appends a dummy value to a given slots in [`GeneralData`]
9		#' class object, if and only if the total number of observations (as indicated
10		#' by `object@nObs`) equals to `1`. Otherwise, the `object` is not changed.
11		#'
12		#' @note The main motivation behind this function is related to the `JAGS`.
13		#' If there is only one observation, the data is not passed correctly to
14		#' `JAGS`, i.e. e.g. `x` and `y` are treated like scalars in the data file.
15		#' Therefore it is necessary to add dummy values to the vectors in this case
16		#' As we don't change the number of observations (`nObs`), this addition of
17		#' zeros doesn't affect the results of `JAGS` computations.
18		#'
19		#' @param object (`GeneralData`)\cr object into which dummy values will be added.
20		#' @param where (`character`)\cr names of slots in `object` to which a `dummy`
21		#' number will be appended.
22		#' @param dummy (`number`)\cr a dummy number that will be appended to selected
23		#' slots in `object`. Default to `0`.
24		#'
25		#' @return A [`GeneralData`] object with slots updated with dummy number.
26		#'
27		#' @export
28		#' @example examples/helpers-jags_add_dummy.R
29		#'
30		h_jags_add_dummy <- function(object, where, dummy = 0) {
31	508x	assert_class(object, "GeneralData")
32	508x	assert_character(where)
33	508x	assert_subset(where, slotNames(object))
34	507x	assert_number(dummy)
35
36	507x	if (object@nObs == 1L) {
37	18x	for (i in where) {
38		# Add dummy value and preserve the class.
39	45x	slot(object, i) <- as(c(slot(object, i), dummy), class(slot(object, i)))
40		}
41		}
42	507x	object
43		}
44
45		#' Joining `JAGS` Models
46		#'
47		#' @description `r lifecycle::badge("stable")`
48		#'
49		#' This helper function joins two JAGS models in the way that the body of the
50		#' second model is appended to the body of the first model (in this order).
51		#' After that, the first, body-extended model is returned. The arguments of
52		#' `model1`, `model2` model functions (if any) are not combined in any way.
53		#'
54		#' @note `model1` and `model2` functions must have a multi-expression
55		#' body, i.e. braced expression(s). Environments or any attributes of the
56		#' function bodies are not preserved in any way after joining.
57		#'
58		#' @param model1 (`function`)\cr the first model to join.
59		#' @param model2 (`function`)\cr the second model to join.
60		#'
61		#' @return joined models.
62		#'
63		#' @export
64		#'
65		h_jags_join_models <- function(model1, model2) {
66	863x	assert_function(model1)
67	863x	assert_function(model2)
68	863x	assert_class(body(model1), "{")
69	862x	assert_class(body(model2), "{")
70
71		# This workaround is needed to avoid bugs related to covr-injected code.
72	862x	if (h_covr_active()) {
73	862x	body(model2) <- h_covr_detrace(body(model2))
74		}
75
76	862x	body2 <- as.list(body(model2))
77	862x	if (length(body2) >= 2) {
78	861x	body1 <- as.list(body(model1))
79	861x	body(model1) <- as.call(c(body1, body2[-1]))
80		}
81	862x	model1
82		}
83
84
85		#' Setting Initial Values for `JAGS` Model Parameters
86		#'
87		#' @description `r lifecycle::badge("experimental")`
88		#'
89		#' A simple helper function that prepares an object for `inits` argument of
90		#' [rjags::jags.model()], which is invoked by [mcmc()] method. The `inits`
91		#' argument specifies initial values for model parameters.
92		#'
93		#' @param model (`GeneralModel`)\cr an input model.
94		#' @param data (`GeneralData`)\cr an input data.
95		#'
96		#' @return A `list` of starting values for parameters required to be initialized
97		#' in the MCMC `JAGS `sampler.
98		#'
99		#' @export
100		#' @example examples/helpers-jags_get_model_inits.R
101		#'
102		h_jags_get_model_inits <- function(model, data) {
103	501x	assert_class(model, "GeneralModel")
104	501x	assert_class(data, "GeneralData")
105
106	501x	inits <- do.call(model@init, h_slots(data, formalArgs(model@init)))
107	501x	assert_list(inits)
108	500x	inits[sapply(inits, length) > 0L]
109		}
110
111		#' Getting Data for `JAGS`
112		#'
113		#' @description `r lifecycle::badge("experimental")`
114		#'
115		#' A simple helper function that prepares an object for `data` argument of
116		#' [rjags::jags.model()], which is invoked by [mcmc()] method.
117		#'
118		#' @param model (`GeneralModel`)\cr an input model.
119		#' @param data (`GeneralData`)\cr an input data.
120		#' @param from_prior (`flag`)\cr sample from the prior only? In this case
121		#' data will not be appended to the output, i.e. only the variables required
122		#' by the `model@priormodel` model will be returned in data.
123		#'
124		#' @export
125		#' @example examples/helpers-jags_get_data.R
126		#'
127		h_jags_get_data <- function(model, data, from_prior) {
128	504x	assert_class(model, "GeneralModel")
129	504x	assert_class(data, "GeneralData")
130	504x	assert_flag(from_prior)
131
132		# 1) Extract variables from `data` as required by `modelspecs`.
133	504x	ms_args_names <- formalArgs(model@modelspecs)
134	504x	ms_args <- if ("from_prior" %in% ms_args_names) {
135	473x	c(h_slots(data, setdiff(ms_args_names, "from_prior")), list(from_prior = from_prior))
136		} else {
137	31x	h_slots(data, ms_args_names)
138		}
139	504x	modelspecs <- do.call(model@modelspecs, ms_args)
140	504x	assert_list(modelspecs)
141
142		# 2) Extract variables from `data` as required by `datanames`.
143	503x	datanames <- if (from_prior) {
144	40x	model@datanames_prior
145		} else {
146	463x	union(model@datanames, model@datanames_prior)
147		}
148
149		# Add dummy to ensure that e.g. `x` and `y` in `data` won't be treated as
150		# scalars by `JAGS` if `data@nObs == 1`, which leads to failures.
151	503x	add_where <- setdiff(datanames, c("nObs", "nGrid", "nObsshare", "yshare", "xshare", "Tmax"))
152	503x	data <- h_jags_add_dummy(data, where = add_where)
153
154	503x	data_model <- h_slots(data, datanames)
155	503x	c(data_model, modelspecs)
156		}
157
158		#' Writing JAGS Model to a File
159		#'
160		#' @description `r lifecycle::badge("stable")`
161		#'
162		#' This function converts a R function with JAGS model into a text and then
163		#' writes it into a given file. During the "model into text" conversion, the
164		#' format of numbers of which absolute value is less than `0.001` or greater
165		#' than `10000` is changed. These numbers will be converted into scientific
166		#' format with specified number of significant digits using [formatC()]
167		#' function.
168		#'
169		#' @note JAGS syntax allows truncation specification like `dnorm(...) I(...)`,
170		#' which is illegal in R. To overcome this incompatibility, use dummy operator
171		#' `\%_\%` before `I(...)`, i.e. `dnorm(...) \%_\% I(...)` in the model's
172		#' code. This dummy operator `\%_\%` will be removed just before saving the
173		#' JAGS code into a file.
174		#' Due to technical issues related to conversion of numbers to scientific
175		#' format, it is required that the body of a model function does not contain
176		#' `TEMP_NUM_PREF_` or `_TEMP_NUM_SUF` character constants in its body.
177		#'
178		#' @param model (`function`)\cr function containing the JAGS model.
179		#' @param file (`string` or `NULL`)\cr the name of the file (including the
180		#' optional path) where the model will be saved. If `NULL`, the file will be
181		#' created in a `R_crmPack` folder placed under temporary directory indicated
182		#' by [tempdir()] function.
183		#' @param digits (`count`)\cr a desired number of significant digits for
184		#' for numbers used in JAGS input, see [formatC()].
185		#' @return The name of the file where the model was saved.
186		#'
187		#' @export
188		#' @example examples/helpers-jags_write_model.R
189		#'
190		h_jags_write_model <- function(model, file = NULL, digits = 5) {
191	530x	assert_function(model)
192	530x	assert_count(digits)
193
194		# This workaround is needed to avoid bugs related to covr-injected code.
195	530x	if (h_covr_active()) {
196	530x	body(model) <- h_covr_detrace(body(model))
197		}
198
199	530x	if (!is.null(file)) {
200	1x	assert_path_for_output(file)
201		} else {
202	529x	dir <- file.path(tempdir(), "R_crmPack")
203		# Don't warn, as the temp dir often exists (which is OK).
204	529x	dir.create(dir, showWarnings = FALSE)
205	529x	file <- tempfile(
206	529x	pattern = "jags_model_fun",
207	529x	tmpdir = dir,
208	529x	fileext = ".txt"
209		)
210		}
211
212		# Replace scientific notation.
213	530x	model_sci_replaced <- h_rapply(
214	530x	x = body(model),
215	530x	fun = h_format_number,
216	530x	classes = c("integer", "numeric"),
217	530x	digits = digits,
218	530x	prefix = "TEMP_NUM_PREF_",
219	530x	suffix = "_TEMP_NUM_SUF"
220		)
221		# Transform `model` body into character vector.
222	530x	model_text <- deparse(model_sci_replaced, control = NULL)
223	530x	model_text <- gsub("\"TEMP_NUM_PREF_\|_TEMP_NUM_SUF\"", "", model_text)
224	530x	model_text <- gsub("%_% ", "", model_text)
225	530x	model_text <- c("model", model_text)
226
227	530x	log_trace("Writting JAGS model function into: %s", file)
228	530x	writeLines(model_text, con = file)
229	530x	file
230		}
231
232		#' Extracting Samples from `JAGS` `mcarray` Object
233		#'
234		#' @description `r lifecycle::badge("stable")`
235		#'
236		#' A simple helper function that extracts a sample from
237		#' [`rjags::mcarray.object`] S3 class object. The [`rjags::mcarray.object`]
238		#' object is used by the [rjags::jags.samples()] function to represent MCMC
239		#' output from a `JAGS` model.
240		#'
241		#' @param x an [`rjags::mcarray.object`] object.
242		#'
243		#' @export
244		#'
245		h_jags_extract_samples <- function(x) {
246	1403x	assert_class(x, "mcarray")
247
248	1403x	x <- x[, , 1L]
249		# In case that there are multiple parameters in a node.
250	1403x	if (is.matrix(x)) {
251	259x	x <- t(x)
252		}
253	1403x	x
254		}

1		# Design ----
2
3		#' Internal Helper Functions for Validation of [`RuleDesign`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`RuleDesign`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_design
11		#' @param object (`RuleDesign`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_design validates that the [`RuleDesign`] object
17		#' contains valid `startingDose`.
18		v_rule_design <- function(object) {
19	10x	v <- Validate()
20	10x	v$check(
21	10x	test_number(object@startingDose, finite = TRUE),
22	10x	"startingDose must be a number"
23		)
24	10x	v$check(
25	10x	test_subset(object@startingDose, choices = object@data@doseGrid, empty.ok = FALSE),
26	10x	"startingDose must be included in data@doseGrid"
27		)
28	10x	v$result()
29		}
30
31		#' Internal Helper Functions for Validation of [`RuleDesignOrdinal`] Objects
32		#'
33		#' @description `r lifecycle::badge("experimental")`
34		#'
35		#' These functions are only used internally to validate the format of an input
36		#' [`RuleDesignOrdinal`] or inherited classes and therefore not exported.
37		#'
38		#' @name v_design
39		#' @param object (`RuleDesignOrdinal`)\cr object to validate.
40		#' @return A `character` vector with the validation failure messages,
41		#' or `TRUE` in case validation passes.
42		NULL
43
44		#' @describeIn v_design validates that the [`RuleDesignOrdinal`] object
45		#' contains valid `starting_dose`.
46		v_rule_design_ordinal <- function(object) {
47	!	v <- Validate()
48	!	v$check(
49	!	test_number(object@starting_dose, finite = TRUE),
50	!	"starting_dose must be a number"
51		)
52	!	v$check(
53	!	test_subset(object@starting_dose, choices = object@data@doseGrid, empty.ok = FALSE),
54	!	"starting_dose must be included in data@doseGrid"
55		)
56	!	v$result()
57		}
58
59
60		#' @describeIn v_design validates that the [`DesignGrouped`] object
61		#' contains valid flags.
62		v_design_grouped <- function(object) {
63	2x	v <- Validate()
64	2x	v$check(
65	2x	test_flag(object@first_cohort_mono_only),
66	2x	"first_cohort_mono_only must be a flag"
67		)
68	2x	v$check(
69	2x	test_flag(object@same_dose_for_all),
70	2x	"same_dose_for_all must be a flag"
71		)
72	2x	v$check(
73	2x	test_flag(object@same_dose_for_all),
74	2x	"same_dose_for_start must be a flag"
75		)
76	2x	v$result()
77		}

1		#' @include helpers_knitr_CohortSize.R
2
3		# Increments ----
4
5		#' Render a `IncrementsRelative` Object
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#' @inherit knit_print.CohortSizeConst return
9		#' @param ... passed to [knitr::kable()]
10		#' @inheritParams knit_print.CohortSizeConst
11		#' @section Usage Notes:
12		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
13		#' of `caption` is `"Defined by highest dose administered so far"`. These
14		#' values can be overridden by passing `col.names` and `caption` in the function
15		#' call.
16		#' @export
17		#' @rdname knit_print
18		knit_print.IncrementsRelative <- function(x, ..., asis = TRUE) {
19	11x	assert_flag(asis)
20
21	9x	param <- list(...)
22	9x	if (!("col.names" %in% names(param))) {
23	9x	param[["col.names"]] <- c("Min", "Max", "Increment")
24		}
25	9x	if (!("caption" %in% names(param))) {
26	9x	param[["caption"]] <- "Defined by highest dose administered so far"
27		}
28	9x	x <- tidy(x)
29	9x	param[["x"]] <- x
30	9x	rv <- kableExtra::add_header_above(
31	9x	do.call(knitr::kable, param),
32	9x	c("Dose" = 2, " " = 1)
33		)
34	9x	if (asis) {
35	6x	rv <- knitr::asis_output(rv)
36		}
37	9x	rv
38		}
39
40		#' Render an `IncrementsRelativeDLT` object
41		#'
42		#' @description `r lifecycle::badge("experimental")`
43		#' @inherit knit_print.CohortSizeConst return
44		#' @param ... passed to [knitr::kable()]
45		#' @inheritParams knit_print.CohortSizeConst
46		#' @section Usage Notes:
47		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
48		#' of `caption` is `"Defined by number of DLTs reported so far"`. These values
49		#' can be overridden by passing `col.names` and `caption` in the function call.
50		#' @export
51		#' @rdname knit_print
52		knit_print.IncrementsRelativeDLT <- function(x, ..., asis = TRUE) {
53	8x	assert_flag(asis)
54
55	6x	param <- list(...)
56	6x	if (!("col.names" %in% names(param))) {
57	6x	param[["col.names"]] <- c("Min", "Max", "Increment")
58		}
59	6x	if (!("caption" %in% names(param))) {
60	6x	param[["caption"]] <- "Defined by number of DLTs reported so far"
61		}
62
63
64	6x	param[["x"]] <- tidy(x)
65	6x	rv <- kableExtra::add_header_above(
66	6x	do.call(knitr::kable, param),
67	6x	c("No DLTs" = 2, " " = 1)
68		)
69	6x	if (asis) {
70	4x	rv <- knitr::asis_output(rv)
71		}
72	6x	rv
73		}
74
75		#' Render an `IncrementsDoseLevels` object
76		#'
77		#' @description `r lifecycle::badge("experimental")`
78		#' @inherit knit_print.CohortSizeConst return
79		#' @inheritParams knit_print.CohortSizeConst
80		#' @export
81		#' @rdname knit_print
82		knit_print.IncrementsDoseLevels <- function(x, ..., asis = TRUE) {
83	5x	assert_flag(asis)
84
85	3x	rv <- paste0(
86	3x	"The maximum increment between cohorts is ",
87	3x	x@levels,
88	3x	ifelse(x@levels == 1, " level", " levels"),
89	3x	" relative to the ",
90	3x	ifelse(x@basis_level == "last", "dose used in the previous cohort.", "highest dose used so far."),
91	3x	"\n"
92		)
93	3x	if (asis) {
94	2x	rv <- knitr::asis_output(rv)
95		}
96	3x	rv
97		}
98
99		#' Render an `IncrementsHSRBeta` object
100		#'
101		#' @description `r lifecycle::badge("experimental")`
102		#' @inherit knit_print.CohortSizeConst return
103		#' @inheritParams knit_print.CohortSizeConst
104		#' @export
105		#' @rdname knit_print
106		knit_print.IncrementsHSRBeta <- function(x, ..., asis = TRUE) {
107	5x	assert_flag(asis)
108
109	3x	rv <- paste0(
110	3x	"The maximum increment is defined by a hard safety rule, independent of the CRM model, ",
111	3x	" and based on a beta(", x@a, ", ", x@b, ") ",
112	3x	"prior with a target toxicity rate of ",
113	3x	x@target,
114	3x	" and a probability threshold of ",
115	3x	x@prob,
116	3x	".\n"
117		)
118	3x	if (asis) {
119	2x	rv <- knitr::asis_output(rv)
120		}
121	3x	rv
122		}
123
124		#' Render an `IncrementsMin` object
125		#'
126		#' @description `r lifecycle::badge("experimental")`
127		#' @inherit knit_print.CohortSizeConst return
128		#' @param ... passed through to the `knit_print` methods of the constituent
129		#' rules
130		#' @inheritParams knit_print.CohortSizeConst
131		#' @export
132		#' @rdname knit_print
133		knit_print.IncrementsMin <- function(x, ..., asis = TRUE) {
134	5x	assert_flag(asis)
135
136	3x	rv <- paste0(
137	3x	"The minimum of the increments defined in the following rules:",
138	3x	paste0(
139	3x	lapply(
140	3x	x@increments_list,
141	3x	function(x, ...) {
142	6x	knit_print(x, asis = asis, ...)
143		}
144		),
145	3x	collapse = "\n"
146		),
147	3x	paste = "\n"
148		)
149	3x	if (asis) {
150	2x	rv <- knitr::asis_output(rv)
151		}
152	3x	rv
153		}
154
155		#' Render an `IncrementsOrdinal` object
156		#' @inherit knit_print.CohortSizeConst return
157		#' @param ... passed through to the `knit_print` method of the standard rule
158		#' @inheritParams knit_print.CohortSizeConst
159		#' @export
160		#' @rdname knit_print
161		knit_print.IncrementsOrdinal <- function(x, ..., asis = TRUE) {
162	5x	assert_flag(asis)
163
164	3x	rv <- paste0(
165	3x	"Based on a toxicity grade of ",
166	3x	x@grade,
167		": ",
168	3x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
169	3x	paste = "\n"
170		)
171	3x	if (asis) {
172	2x	rv <- knitr::asis_output(rv)
173		}
174	3x	rv
175		}
176
177		#' Render an `IncrementsRelativeParts` object
178		#'
179		#' @inherit knit_print.CohortSizeConst return
180		#' @param labels (`character`)\cr The word used to describe toxicities. See
181		#' Usage Notes below.
182		#' @inheritParams knit_print.CohortSizeConst
183		#' @section Usage Notes:
184		#' `labels` defines how toxicities are described.
185		#'
186		#' It should be a character vector of length 1 or 2. If of length 2, the first
187		#' element describes a single toxicity and the second describes all other
188		#' toxicity counts. If of length 1, the character `s` is appended to the value
189		#' describing a single toxicity.
190		#'
191		#' @export
192		#' @rdname knit_print
193		knit_print.IncrementsRelativeParts <- function(x, ..., asis = TRUE, labels = c("toxicity", "toxicities")) {
194	6x	assert_flag(asis)
195	4x	assert_character(labels, min.len = 1, max.len = 2, any.missing = FALSE)
196
197	4x	if (length(labels) == 1) {
198	!	labels[2] <- paste0(labels[1], "s")
199		}
200	4x	rv <- paste0(
201	4x	"The maximum increment in Part 1 is defined by the `part1Ladder` slot of ",
202	4x	"the associated `DataParts` object.\n\n",
203	4x	"If no ", labels[2], " are reported in Part 1, the starting dose for Part 2 ",
204	4x	"will be ",
205	4x	ifelse(
206	4x	x@clean_start == 0,
207	4x	"the highest dose used in Part 1.\n\n",
208	4x	paste0(
209	4x	x@clean_start,
210	4x	ifelse(abs(x@clean_start) == 1, " dose ", " doses "),
211	4x	ifelse(x@clean_start < 0, "below ", "above "),
212	4x	"the highest dose used in Part 1.\n\n"
213		)
214		),
215	4x	"If one or more ", labels[2], " are reported in Part 1, the starting dose for Part 2 ",
216	4x	"will be ",
217	4x	ifelse(
218	4x	x@dlt_start == 0,
219	4x	"the highest dose used in Part 1.\n\n",
220	4x	paste0(
221	4x	abs(x@dlt_start),
222	4x	ifelse(abs(x@dlt_start) == 1, " dose ", " doses "),
223	4x	ifelse(x@dlt_start < 0, "below ", "above "),
224	4x	"the highest dose used in Part 1.\n\n"
225		)
226		),
227	4x	"Once Part 2 has started, the maximum increment in dose levels will be based ",
228	4x	"on the number of ", labels[2], " reported so far, as described in the ",
229	4x	"following table:"
230		)
231
232	4x	param <- list(...)
233	4x	if (!("col.names" %in% names(param))) {
234	4x	param[["col.names"]] <- c("Lower", "Upper", "Increment")
235		}
236	4x	if (!("caption" %in% names(param))) {
237	4x	param[["caption"]] <- paste0("Defined by the number of ", labels[2], " reported so far")
238		}
239	4x	header <- c(2, 1)
240	4x	headerLabel <- labels[2]
241	4x	substr(headerLabel, 1, 1) <- toupper(substr(headerLabel, 1, 1))
242	4x	names(header) <- c(headerLabel, " ")
243	4x	param[["x"]] <- tibble(
244	4x	intervals = x@intervals
245		) %>%
246	4x	h_range_to_minmax(intervals) %>%
247	4x	tibble::add_column(increments = c(0, x@increments))
248	4x	d_tab <- kableExtra::add_header_above(
249	4x	do.call(knitr::kable, param),
250	4x	header
251		)
252	4x	rv <- paste(rv, d_tab)
253	4x	if (asis) {
254	3x	rv <- knitr::asis_output(rv)
255		}
256	4x	rv
257		}
258
259		#' Render an `IncrementsRelativeDLTCurrent` object
260		#'
261		#' @description `r lifecycle::badge("experimental")`
262		#' @inherit knit_print.CohortSizeConst return
263		#' @param labels (`character`)\cr The word used to describe toxicities. See
264		#' Usage Notes below.
265		#' @param ... passed to [knitr::kable()]
266		#' @inheritParams knit_print.CohortSizeConst
267		#' @section Usage Notes:
268		#' The default value of `col.names` is `c("Min", "Max", "Increment")` and that
269		#' of `caption` is `"Defined by number of DLTs in the current cohort"`. These values
270		#' can be overridden by passing `col.names` and `caption` in the function call.
271		#'
272		#' `labels` defines how toxicities are described.
273		#'
274		#' It should be a character vector of length 1 or 2. If of length 2, the first
275		#' element describes a single toxicity and the second describes all other
276		#' toxicity counts. If of length 1, the character `s` is appended to the value
277		#' describing a single toxicity.
278		#'
279		#' @export
280		#' @rdname knit_print
281		knit_print.IncrementsRelativeDLTCurrent <- function(x, ..., asis = TRUE, labels = c("DLT", "DLTs")) {
282	5x	assert_flag(asis)
283	3x	assert_character(labels, min.len = 1, max.len = 2, any.missing = FALSE)
284
285	3x	if (length(labels) == 1) {
286	!	labels[2] <- paste0(labels[1], "s")
287		}
288
289	3x	param <- list(...)
290	3x	if (!("col.names" %in% names(param))) {
291	3x	param[["col.names"]] <- c("Min", "Max", "Increment")
292		}
293	3x	if (!("caption" %in% names(param))) {
294	3x	param[["caption"]] <- "Defined by number of DLTs reported in the current cohort"
295		}
296	3x	param[["x"]] <- tidy(x)
297	3x	rv <- kableExtra::add_header_above(
298	3x	do.call(knitr::kable, param),
299	3x	c("No DLTs" = 2, " " = 1)
300		)
301	3x	if (asis) {
302	2x	rv <- knitr::asis_output(rv)
303		}
304	3x	rv
305		}

1		# StoppingOrdinal ----
2
3		#' @description `r lifecycle::badge("experimental")`
4		#' @inheritParams knit_print.StoppingTargetProb
5		#' @rdname knit_print
6		#' @export
7		#' @method knit_print StoppingOrdinal
8		knit_print.StoppingOrdinal <- function(
9		x,
10		...,
11		asis = TRUE) {
12	7x	assert_flag(asis)
13
14	5x	rv <- paste0(
15	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
16	5x	"Based on a toxicity grade of ",
17	5x	x@grade,
18		": ",
19	5x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n")
20		)
21
22	5x	if (asis) {
23	2x	rv <- knitr::asis_output(rv)
24		}
25	5x	rv
26		}
27
28		# StoppingMaxGainCIRatio ----
29
30		#' @description `r lifecycle::badge("experimental")`
31		#' @inheritParams knit_print.StoppingTargetProb
32		#' @rdname knit_print
33		#' @export
34		#' @method knit_print StoppingMaxGainCIRatio
35		knit_print.StoppingMaxGainCIRatio <- function(
36		x,
37		...,
38		asis = TRUE) {
39	7x	assert_flag(asis)
40
41	5x	rv <- paste0(
42	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
43	5x	"If the ratio of the upper to the lower limit of the posterior 95% credible ",
44	5x	"interval for the probability of toxicity at the target dose (the smaller ",
45	5x	"of the MTD for ",
46	5x	100 * x@prob_target,
47	5x	"% target and GStar) is less than or equal to ",
48	5x	x@target_ratio,
49		"."
50		)
51
52	5x	if (asis) {
53	2x	rv <- knitr::asis_output(rv)
54		}
55	5x	rv
56		}
57
58		# StoppingList ----
59
60		#' @description `r lifecycle::badge("experimental")`
61		#' @inheritParams knit_print.StoppingTargetProb
62		#' @param preamble (`character`)\cr the text that introduces the list of rules
63		#' @rdname knit_print
64		#' @export
65		#' @method knit_print StoppingList
66		knit_print.StoppingList <- function(
67		x,
68		...,
69		preamble = "If the result of applying the summary function to the following rules is `TRUE`:\n",
70		asis = TRUE) {
71	21x	assert_flag(asis)
72	15x	assert_character(preamble, len = 1, any.missing = FALSE)
73
74	15x	rules_list <- paste0(
75	15x	lapply(
76	15x	x@stop_list,
77	15x	function(z) {
78	45x	paste0("- ", knit_print(z, asis = FALSE, ...))
79		}
80		),
81	15x	collapse = "\n"
82		)
83	15x	rv <- paste0(
84	15x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
85	15x	preamble,
86	15x	"\n",
87	15x	rules_list
88		)
89
90	15x	if (asis) {
91	6x	rv <- knitr::asis_output(rv)
92		}
93	15x	rv
94		}
95
96		# StoppingAny ----
97
98		#' @description `r lifecycle::badge("experimental")`
99		#' @inheritParams knit_print.StoppingList
100		#' @rdname knit_print
101		#' @export
102		#' @method knit_print StoppingAny
103		knit_print.StoppingAny <- function(
104		x,
105		...,
106		preamble = "If any of the following rules are `TRUE`:\n",
107		asis = TRUE) {
108	7x	knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
109		}
110
111		#' @description `r lifecycle::badge("experimental")`
112		#' @inheritParams knit_print.StoppingList
113		#' @rdname knit_print
114		#' @export
115		#' @method knit_print StoppingAll
116		knit_print.StoppingAll <- function(
117		x,
118		...,
119		preamble = "If all of the following rules are `TRUE`:\n",
120		asis = TRUE) {
121	7x	knit_print.StoppingList(x, ..., preamble = preamble, asis = asis)
122		}
123
124		# StoppingTDCIRatio ----
125
126		#' @description `r lifecycle::badge("experimental")`
127		#' @inheritParams knit_print.StoppingTargetProb
128		#' @rdname knit_print
129		#' @export
130		#' @method knit_print StoppingTDCIRatio
131		knit_print.StoppingTDCIRatio <- function(
132		x,
133		...,
134		dose_label = "the next best dose",
135		tox_label = "toxicity",
136		fmt_string = paste0(
137		"%sIf, at %s, the ratio of the upper to the lower limit of the posterior ",
138		"95%% credible interval for %s (targetting %2.0f%%) is less than or equal to "
139		),
140		asis = TRUE) {
141	7x	assert_flag(asis)
142	5x	assert_character(fmt_string, len = 1, any.missing = FALSE)
143	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
144	5x	assert_character(dose_label, len = 1, any.missing = FALSE)
145
146	5x	rv <- paste0(
147	5x	sprintf(
148	5x	fmt_string,
149	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
150	5x	dose_label,
151	5x	tox_label,
152	5x	100 * x@prob_target
153		),
154	5x	x@target_ratio,
155		"."
156		)
157
158	5x	if (asis) {
159	2x	rv <- knitr::asis_output(rv)
160		}
161	5x	rv
162		}
163
164		# StoppingTargetBiomarker ----
165
166		#' @description `r lifecycle::badge("experimental")`
167		#' @inheritParams knit_print.StoppingTargetProb
168		#' @param biomarker_label (`character`)\cr the term used to describe the biomarker
169		#' @rdname knit_print
170		#' @export
171		#' @method knit_print StoppingTargetBiomarker
172		knit_print.StoppingTargetBiomarker <- function(
173		x,
174		...,
175		dose_label = "the next best dose",
176		biomarker_label = "the target biomarker",
177		fmt_string = paste0(
178		"%sIf, at %s, the posterior probability that %s is in the range ",
179		"(%.2f, %.2f)%s is %.0f%% or more."
180		),
181		asis = TRUE) {
182	8x	assert_flag(asis)
183	6x	assert_character(fmt_string, len = 1, any.missing = FALSE)
184	6x	assert_character(biomarker_label, len = 1, any.missing = FALSE)
185
186	6x	rv <- sprintf(
187	6x	fmt_string,
188	6x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
189	6x	dose_label,
190	6x	biomarker_label,
191	6x	x@target[1],
192	6x	x@target[2],
193	6x	ifelse(
194	6x	x@is_relative,
195	6x	paste0(", relative to the maximum value of ", biomarker_label, ","),
196		""
197		),
198	6x	100 * x@prob
199		)
200
201	6x	if (asis) {
202	3x	rv <- knitr::asis_output(rv)
203		}
204	6x	rv
205		}
206
207		# StoppingLowestDoseHSRBeta ----
208
209		#' @description `r lifecycle::badge("experimental")`
210		#' @inheritParams knit_print.StoppingTargetProb
211		#' @rdname knit_print
212		#' @export
213		#' @method knit_print StoppingLowestDoseHSRBeta
214		knit_print.StoppingLowestDoseHSRBeta <- function(
215		x,
216		...,
217		tox_label = "toxicity",
218		fmt_string = paste0(
219		"%sIf, using a Hard Stopping Rule with a prior of Beta(%.0f, %.0f), the ",
220		"lowest dose in the dose grid has a posterior probability of %s of ",
221		"%.0f%% or more."
222		),
223		asis = TRUE) {
224	7x	assert_flag(asis)
225	5x	assert_character(fmt_string, len = 1, any.missing = FALSE)
226
227	5x	rv <- sprintf(
228	5x	fmt_string,
229	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
230	5x	x@a,
231	5x	x@b,
232	5x	tox_label,
233	5x	100 * x@prob
234		)
235
236	5x	if (asis) {
237	2x	rv <- knitr::asis_output(rv)
238		}
239	5x	rv
240		}
241
242		# StoppingMTDCV ----
243
244		#' @description `r lifecycle::badge("experimental")`
245		#' @inheritParams knit_print.StoppingTargetProb
246		#' @rdname knit_print
247		#' @export
248		#' @method knit_print StoppingMTDCV
249		knit_print.StoppingMTDCV <- function(
250		x,
251		...,
252		fmt_string = paste0(
253		"%sIf the posterior estimate of the robust coefficient of variation of ",
254		"the MTD (targetting %2.0f%%), is than or equal to %.0f%%."
255		),
256		asis = TRUE) {
257	7x	assert_flag(asis)
258	5x	assert_character(fmt_string, len = 1, any.missing = FALSE)
259
260	5x	rv <- sprintf(
261	5x	fmt_string,
262	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
263	5x	100 * x@target,
264	5x	100 * x@thresh_cv
265		)
266
267	5x	if (asis) {
268	2x	rv <- knitr::asis_output(rv)
269		}
270	5x	rv
271		}
272
273		# StoppingMTDdistribution ----
274
275		#' @description `r lifecycle::badge("experimental")`
276		#' @inheritParams knit_print.StoppingTargetProb
277		#' @rdname knit_print
278		#' @export
279		#' @method knit_print StoppingMTDdistribution
280		knit_print.StoppingMTDdistribution <- function(
281		x,
282		...,
283		fmt_string = "%sIf the mean posterior probability of %s at %.0f%% of %s is at least %4.2f.",
284		dose_label = "the next best dose",
285		tox_label = "toxicity",
286		asis = TRUE) {
287	7x	assert_flag(asis)
288	5x	assert_character(dose_label, len = 1, any.missing = FALSE)
289	5x	assert_character(tox_label, len = 1, any.missing = FALSE)
290	5x	assert_character(fmt_string, len = 1, any.missing = FALSE)
291
292	5x	rv <- sprintf(
293	5x	fmt_string,
294	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
295	5x	tox_label,
296	5x	100 * x@thresh,
297	5x	dose_label,
298	5x	x@prob
299		)
300
301	5x	if (asis) {
302	2x	rv <- knitr::asis_output(rv)
303		}
304	5x	rv
305		}
306
307		# StoppingHighestDose ----
308
309		#' @description `r lifecycle::badge("experimental")`
310		#' @param asis (`flag`)\cr Not used at present
311		#' @rdname knit_print
312		#' @export
313		#' @method knit_print StoppingHighestDose
314		knit_print.StoppingHighestDose <- function(
315		x,
316		...,
317		dose_label = "the highest dose in the dose grid",
318		asis = TRUE) {
319	7x	rv <- paste0(
320	7x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
321	7x	"If the next best dose is ",
322	7x	dose_label, "."
323		)
324
325	7x	if (asis) {
326	2x	rv <- knitr::asis_output(rv)
327		}
328	5x	rv
329		}
330
331		# StoppingSpecificDose ----
332
333		#' @description `r lifecycle::badge("experimental")`
334		#' @param asis (`flag`)\cr Not used at present
335		#' @inheritParams knit_print.StoppingTargetProb
336		#' @rdname knit_print
337		#' @export
338		#' @method knit_print StoppingSpecificDose
339		knit_print.StoppingSpecificDose <- function(
340		x,
341		...,
342		dose_label = as.character(x@dose),
343		asis = TRUE) {
344	7x	x@rule@report_label <- x@report_label
345	7x	knit_print(
346	7x	x@rule,
347		...,
348	7x	dose_label = dose_label,
349	7x	asis = asis
350		)
351		}
352
353		# StoppingTargetProb ----
354
355		#' @description `r lifecycle::badge("experimental")`
356		#' @param asis (`flag`)\cr Not used at present
357		#' @param fmt_string (`character`)\cr the character string that defines the format
358		#' of the output
359		#' @param dose_label (`character`)\cr the term used to describe the target dose
360		#' @param tox_label (`character`)\cr the term used to describe toxicity
361		#' @rdname knit_print
362		#' @export
363		#' @method knit_print StoppingTargetProb
364		knit_print.StoppingTargetProb <- function(
365		x,
366		...,
367		fmt_string = "%sIf the probability of %s at %s is in the range [%4.2f, %4.2f] is at least %4.2f.",
368		dose_label = "the next best dose",
369		tox_label = "toxicity",
370		asis = TRUE) {
371	34x	assert_flag(asis)
372	30x	assert_character(dose_label, len = 1, any.missing = FALSE)
373	30x	assert_character(tox_label, len = 1, any.missing = FALSE)
374	30x	assert_character(fmt_string, len = 1, any.missing = FALSE)
375
376	30x	rv <- sprintf(
377	30x	fmt_string,
378	30x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
379	30x	tox_label,
380	30x	dose_label,
381	30x	x@target[1],
382	30x	x@target[2],
383	30x	x@prob
384		)
385
386	30x	if (asis) {
387	6x	rv <- knitr::asis_output(rv)
388		}
389	30x	rv
390		}
391
392		# StoppingMinCohorts ----
393
394		#' @description `r lifecycle::badge("experimental")`
395		#' @param asis (`flag`)\cr Not used at present
396		#' @rdname knit_print
397		#' @export
398		#' @method knit_print StoppingMinCohorts
399		knit_print.StoppingMinCohorts <- function(
400		x,
401		...,
402		asis = TRUE) {
403	22x	assert_flag(asis)
404
405	20x	rv <- paste0(
406	20x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
407	20x	"If ",
408	20x	x@nCohorts,
409	20x	" or more cohorts have been treated."
410		)
411	20x	if (asis) {
412	2x	rv <- knitr::asis_output(rv)
413		}
414	20x	rv
415		}
416
417		# StoppingMinPatients ----
418
419		#' @description `r lifecycle::badge("experimental")`
420		#' @param label (`character`)\cr the term used to label participants
421		#' @param asis (`flag`)\cr Not used at present
422		#' @rdname knit_print
423		#' @export
424		#' @method knit_print StoppingMinPatients
425		knit_print.StoppingMinPatients <- function(
426		x,
427		...,
428		label = "participants",
429		asis = TRUE) {
430	22x	assert_flag(asis)
431	20x	assert_character(label, len = 1, any.missing = FALSE)
432
433	20x	rv <- paste0(
434	20x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
435	20x	"If ",
436	20x	x@nPatients,
437	20x	paste0(" or more ", label, " have been treated.")
438		)
439	20x	if (asis) {
440	2x	rv <- knitr::asis_output(rv)
441		}
442	20x	rv
443		}
444
445		# StoppingPatientsNearDose ----
446
447		#' @description `r lifecycle::badge("experimental")`
448		#' @param label (`character`)\cr the term used to label participants
449		#' @inheritParams knit_print.StoppingTargetProb
450		#' @param asis (`flag`)\cr Not used at present
451		#' @rdname knit_print
452		#' @export
453		#' @method knit_print StoppingPatientsNearDose
454		knit_print.StoppingPatientsNearDose <- function(
455		x,
456		...,
457		dose_label = "the next best dose",
458		label = "participants",
459		asis = TRUE) {
460	7x	assert_flag(asis)
461	5x	assert_character(label, len = 1, any.missing = FALSE)
462	5x	assert_character(dose_label, len = 1, any.missing = FALSE)
463
464	5x	rv <- paste0(
465	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
466	5x	"If ",
467	5x	x@nPatients,
468	5x	paste0(" or more ", label, " have been treated "),
469	5x	ifelse(
470	5x	x@percentage == 0,
471	5x	"at ",
472	5x	paste0("within ", x@percentage, "% of ")
473		),
474	5x	dose_label,
475		"."
476		)
477	5x	if (asis) {
478	2x	rv <- knitr::asis_output(rv)
479		}
480	5x	rv
481		}
482
483		# StoppingCohortsNearDose ----
484
485		#' @description `r lifecycle::badge("experimental")`
486		#' @param asis (`flag`)\cr Not used at present
487		#' @inheritParams knit_print.StoppingTargetProb
488		#' @rdname knit_print
489		#' @export
490		#' @method knit_print StoppingCohortsNearDose
491		knit_print.StoppingCohortsNearDose <- function(
492		x,
493		...,
494		dose_label = "the next best dose",
495		asis = TRUE) {
496	7x	assert_flag(asis)
497	5x	assert_character(dose_label, len = 1, any.missing = FALSE)
498
499	5x	rv <- paste0(
500	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
501	5x	"If ",
502	5x	x@nCohorts,
503	5x	" or more cohorts have been treated ",
504	5x	ifelse(
505	5x	x@percentage == 0,
506	5x	"at ",
507	5x	paste0("within ", x@percentage, "% of ")
508		),
509	5x	dose_label,
510		"."
511		)
512	5x	if (asis) {
513	2x	rv <- knitr::asis_output(rv)
514		}
515	5x	rv
516		}
517
518		# StoppingMissingDose ----
519
520		#' @description `r lifecycle::badge("experimental")`
521		#' @param asis (`flag`)\cr Not used at present
522		#' @rdname knit_print
523		#' @export
524		#' @method knit_print StoppingMissingDose
525		knit_print.StoppingMissingDose <- function(
526		x,
527		...,
528		asis = TRUE) {
529	7x	assert_flag(asis)
530
531	5x	rv <- paste0(
532	5x	ifelse(is.na(x@report_label), "", paste0(x@report_label, ": ")),
533	5x	"If the dose returned by <code>nextBest()</code> is ",
534	5x	"<code>NA</code>, or if the trial includes a placebo dose, the placebo dose."
535		)
536	5x	if (asis) {
537	2x	rv <- knitr::asis_output(rv)
538		}
539	5x	rv
540		}

1		#' Helper Function to Blind Plot Data
2		#'
3		#' @param df (`GeneralData`)\cr The data to be blinded
4		#' @param blind (`flag`)\cr Should the data be blinded?
5		#' @param has_placebo (`flag`)\cr Does the data contain a placebo dose?
6		#' @param pbo_dose (`positive_number`)\cr The dose to be taken as placebo.
7		#' Ignored if `has_placebo` is `FALSE`
8		#' @returns The blinded data
9		h_blind_plot_data <- function(df, blind, has_placebo, pbo_dose) {
10	19x	if (blind) {
11		# This is to blind the data.
12		# For each cohort, all DLTs are assigned to the first subjects in the cohort.
13		# In addition, the placebo (if any) is set to the active dose level for that
14		# cohort.
15		# Notice: dapply reorders records of df according to the lexicographic order
16		# of cohort.
17	9x	df <- dapply(df, f = ~cohort, FUN = function(coh) {
18	30x	coh$toxicity <- sort(coh$toxicity, decreasing = TRUE)
19	30x	coh$dose <- max(coh$dose)
20	30x	coh
21		})
22	10x	} else if (has_placebo) {
23		# Placebo will be plotted at y = 0 level.
24	8x	df$dose[df$dose == pbo_dose] <- 0
25		}
26	19x	df
27		}
28
29		# h_plot_data_df ----
30
31		## generic ----
32
33		#' Helper Function for the Plot Method of subclasses of [`GeneralData`]
34		#'
35		#' @description `r lifecycle::badge("experimental")`
36		#'
37		#' A method that transforms [`GeneralData`] objects into a `tibble` suitable for
38		#' plotting with `ggplot2` methods
39		#'
40		#' @param data (`GeneralData`)\cr object from which data is extracted and converted
41		#' into a data frame.
42		#' @param ... further arguments passed to class-specific methods.
43		#' @return `data.frame` containing columns for patient, cohort, dose and toxicity grade
44		#' @aliases h_plot_data_df
45		#'
46		setGeneric(
47		name = "h_plot_data_df",
48		def = function(data, ...) standardGeneric("h_plot_data_df"),
49		valueClass = "data.frame"
50		)
51
52		# Data ----
53
54		#' Helper Function for the Plot Method of [`Data`]
55		#'
56		#' @param data (`Data`)\cr object from which data is extracted and converted
57		#' into a data frame.
58		#' @param blind (`flag`)\cr should data be blinded?
59		#' If `TRUE`, then for each cohort, all DLTs are assigned to the first
60		#' subjects in the cohort. In addition, the placebo (if any) is set to the
61		#' active dose level for that cohort.
62		#' @param legend (`flag`)\cr Display the legend for the toxicity categories
63		#' @param ... further arguments passed to `data.frame` constructor.
64		#' It can be e.g. an extra `column_name = value` pair based on a slot
65		#' from `x` (which in this case might be a subclass of `Data`)
66		#' which does not appear in `Data`.
67		#' @return A `data.frame` object with columns patient, ID, cohort, dose and
68		#' toxicity.
69		#' @describeIn h_plot_data_df method for [`Data`].
70		setMethod(
71		f = "h_plot_data_df",
72		signature = signature(data = "Data"),
73		definition = function(data, blind = FALSE, legend = TRUE, ...) {
74	17x	df <- data.frame(
75	17x	patient = seq_along(data@x),
76	17x	ID = paste(" ", data@ID),
77	17x	cohort = data@cohort,
78	17x	dose = data@x,
79	17x	toxicity = ifelse(data@y == 1, "Yes", "No"),
80		...
81		)
82	17x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
83	17x	df
84		}
85		)
86
87		# DataOrdinal ----
88
89		#' Helper Function for the Plot Method of [`DataOrdinal`]
90		#'
91		#' @describeIn h_plot_data_df Class specific method for [`DataOrdinal`]
92		setMethod(
93		f = "h_plot_data_df",
94		signature = signature(data = "DataOrdinal"),
95		definition = function(data, blind = FALSE, legend = TRUE, ...) {
96	2x	df <- data.frame(
97	2x	patient = seq_along(data@x),
98	2x	ID = paste(" ", data@ID),
99	2x	cohort = data@cohort,
100	2x	dose = data@x,
101	2x	toxicity = names(data@yCategories)[1 + data@y],
102		...
103		)
104	2x	df <- h_blind_plot_data(df, blind, data@placebo, data@doseGrid[1])
105	2x	df
106		}
107		)
108
109
110		# h_plot_data_dataordinal
111
112		## Data ----
113
114		#' Helper Function for the Plot Method of the Data and DataOrdinal Classes
115		#'
116		#' @description `r lifecycle::badge("stable")`
117		#'
118		#' A method that creates a plot for [`Data`] and [`DataOrdinal`] objects.
119		#'
120		#' @note The default values of `tox_shapes` and `tox_labels` result in DLTs
121		#' being displayed as red triangles and other responses as black circles.
122		#' @return The [`ggplot2`] object.
123		#'
124		#' @rdname plot-Data
125		h_plot_data_dataordinal <- function(
126		x,
127		blind = FALSE,
128		legend = TRUE,
129		tox_labels = c(Yes = "red", No = "black"),
130		tox_shapes = c(Yes = 17L, No = 16L),
131		...) {
132	10x	assert_flag(blind)
133	10x	assert_flag(legend)
134	10x	assert_character(tox_labels, any.missing = FALSE, unique = TRUE)
135	10x	assert_integer(tox_shapes, any.missing = FALSE, unique = TRUE)
136	10x	assert_true(length(tox_shapes) == length(tox_labels))
137	10x	assert_subset(x@y, as.integer(0:(length(tox_shapes) - 1)))
138	10x	if (x@nObs == 0L) {
139	!	return()
140		}
141	10x	df <- h_plot_data_df(x, blind, ...)
142
143	10x	p <- ggplot(df, aes(x = patient, y = dose)) +
144	10x	geom_point(aes(shape = toxicity, colour = toxicity), size = 3) +
145	10x	scale_colour_manual(
146	10x	name = "Toxicity",
147	10x	values = tox_labels,
148	10x	breaks = names(tox_labels),
149	10x	guide = guide_legend(reverse = TRUE)
150		) +
151	10x	scale_shape_manual(
152	10x	name = "Toxicity",
153	10x	values = tox_shapes,
154	10x	breaks = names(tox_shapes),
155	10x	guide = guide_legend(reverse = TRUE)
156		) +
157	10x	scale_x_continuous(breaks = df$patient, minor_breaks = NULL) +
158	10x	scale_y_continuous(
159	10x	breaks = sort(unique(c(0, df$dose))),
160	10x	minor_breaks = NULL,
161	10x	limits = c(0, max(df$dose) * 1.1)
162		) +
163	10x	xlab("Patient") +
164	10x	ylab("Dose Level")
165
166	10x	p <- p + h_plot_data_cohort_lines(df$cohort, placebo = x@placebo)
167
168	10x	if (!blind) {
169	4x	p <- p +
170	4x	geom_text(
171	4x	aes(label = ID, size = 2),
172	4x	data = df,
173	4x	hjust = 0,
174	4x	vjust = 0.5,
175	4x	angle = 90,
176	4x	colour = "black",
177	4x	show.legend = FALSE
178		)
179		}
180
181	10x	if (!legend) {
182	6x	p <- p + theme(legend.position = "none")
183		}
184
185	10x	p
186		}
187
188		#' Helper Function Containing Common Functionality
189		#'
190		#' Used by `dose_grid_range-Data` and `dose_grid_range-DataOrdinal`
191		#' @param object (`Data` or `DataOrdinal`)\cr the object for which the dose grid
192		#' range is required
193		#' @param ignore_placebo (`flag`)\cr should placebo dose (if any) not be counted?
194		#'
195		h_obtain_dose_grid_range <- function(object, ignore_placebo) {
196	168x	assert_flag(ignore_placebo)
197
198	166x	dose_grid <- if (ignore_placebo && object@placebo && object@nGrid >= 1) {
199	12x	object@doseGrid[-1]
200		} else {
201	154x	object@doseGrid
202		}
203
204	166x	if (length(dose_grid) == 0L) {
205	10x	c(-Inf, Inf)
206		} else {
207	156x	range(dose_grid)
208		}
209		}
210
211		#' Convert a Ordinal Data to the Equivalent Binary Data for a Specific
212		#' Grade
213		#'
214		#' @description `r lifecycle::badge("experimental")`
215		#'
216		#' A simple helper function that takes a [`DataOrdinal`] object and an
217		#' integer grade and converts them to the equivalent `Data` object.
218		#'
219		#' @param data_ord (`DataOrdinal`)\cr the `DataOrdinal` object to covert
220		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
221		#' is required.
222		#' @return A [`Data`] object.
223		#'
224		#' @export
225		h_convert_ordinal_data <- function(data_ord, grade) {
226		# Validate
227	27x	assert_integer(grade, len = 1, lower = 1)
228	27x	assert_class(data_ord, "DataOrdinal")
229		# Execute
230	27x	Data(
231	27x	ID = data_ord@ID,
232	27x	cohort = data_ord@cohort,
233	27x	x = data_ord@x,
234	27x	y = as.integer(data_ord@y >= grade),
235	27x	doseGrid = data_ord@doseGrid,
236	27x	nGrid = data_ord@nGrid,
237	27x	xLevel = data_ord@xLevel,
238	27x	placebo = data_ord@placebo
239		)
240		}

1		# GeneralSimulations ----
2
3		#' Internal Helper Functions for Validation of [`GeneralSimulations`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`GeneralSimulations`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_general_simulations
11		#' @param object (`GeneralSimulations`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_general_simulations validates that the [`GeneralSimulations`] object
17		#' contains valid `data` object and valid `dose` simulations.
18
19		v_general_simulations <- function(object) {
20	!	v <- Validate()
21
22	!	nSims <- length(object@data)
23
24	!	v$check(
25	!	all(sapply(object@data, is, "Data")),
26	!	"all data elements must be Data objects"
27		)
28	!	v$check(
29	!	identical(length(object@doses), nSims),
30	!	"doses must have same length as the data list"
31		)
32
33	!	v$result()
34		}
35
36		#' @describeIn v_general_simulations validates that the [`Simulations`] object
37		#' contains valid object `fit`, `stop_reasons`, `stop_report`, and
38		#' `additional_stats` compared to the general class [`GeneralSimulations`].
39		#'
40		v_simulations <- function(object) {
41	!	v <- Validate()
42
43	!	nSims <- length(object@data)
44
45	!	v$check(
46	!	identical(length(object@fit), nSims),
47	!	"fit must have same length as data"
48		)
49	!	v$check(
50	!	identical(length(object@stop_reasons), nSims),
51	!	"stop_reasons must have same length as data"
52		)
53
54	!	v$check(
55	!	checkmate::test_matrix(object@stop_report,
56	!	mode = "logical",
57	!	nrows = nSims,
58	!	min.cols = 1,
59	!	any.missing = FALSE
60		),
61	!	"stop_report must be a matrix of mode logical in which the number of rows
62	!	equals the number of simulations and which must not contain any missing values"
63		)
64
65	!	v$result()
66		}
67
68		#' @describeIn v_general_simulations validates that the [`DualSimulations`] object and
69		#' capture the dose-biomarker `fits`, and the `sigma2W` and `rho` estimates.
70		#'
71		v_dual_simulations <- function(object) {
72	!	v <- Validate()
73
74	!	nSims <- length(object@data)
75
76	!	v$check(
77	!	identical(length(object@fit_biomarker), nSims),
78	!	"fit_biomarker list has to have same length as data"
79		)
80	!	v$check(
81	!	identical(length(object@rho_est), nSims),
82	!	"rho_est vector has to have same length as data"
83		)
84	!	v$check(
85	!	identical(length(object@sigma2w_est), nSims),
86	!	"sigma2w_est has to have same length as data"
87		)
88
89	!	v$result()
90		}
91
92		# PseudoSimulations ----
93
94		#' Internal Helper Functions for Validation of [`PseudoSimulations`] Objects
95		#'
96		#' @description `r lifecycle::badge("stable")`
97		#'
98		#' These functions are only used internally to validate the format of an input
99		#' [`PseudoSimulations`] or inherited classes and therefore not exported.
100		#'
101		#' @name v_pseudo_simulations
102		#' @param object (`PseudoSimulations`)\cr object to validate.
103		#' @return A `character` vector with the validation failure messages,
104		#' or `TRUE` in case validation passes.
105		NULL
106
107		#' @describeIn v_pseudo_simulations validates that the [`PseudoSimulations`] object
108		#' contains valid `fit`, `FinalTDtargetEndOfTrialEstimates` ,
109		#' `FinalTDtargetDuringTrialAtDoseGrid`,`FinalTDtargetEndOfTrialAtDoseGrid` ,
110		#' `FinalTDEOTCIs`, `FinalTDEOTRatios`, `FinalCIs`, `FinalRatios`,
111		#' object and valid `stopReasons` simulations.
112
113		v_pseudo_simulations <- function(object) {
114	!	v <- Validate()
115
116	!	nSims <- length(object@data)
117	!	v$check(
118	!	identical(length(object@stop_reasons), nSims),
119	!	"stopReasons must have same length as data"
120		)
121
122	!	v$result()
123		}
124
125		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualSimulations`] object
126		#' contains valid `fitEff`, `FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
127		#' `FinalGstarCIs` , `FinalGstarRatios`, `FinalOptimalDose`, `FinalOptimalDoseAtDoseGrid`
128		#' object and valid `sigma2est` simulations.
129
130		v_pseudo_dual_simulations <- function(object) {
131	!	v <- Validate()
132	!	nSims <- length(object@data)
133	!	v$check(
134	!	identical(length(object@sigma2est), nSims),
135	!	"sigma2est has to have same length as data"
136		)
137	!	v$result()
138		}
139
140		#' @describeIn v_pseudo_simulations validates that the [`PseudoDualFlexiSimulations`]
141		#' object contains valid `sigma2betaWest` vector of the final posterior mean
142		#' sigma2betaW estimates.`FinalGstarEstimates` , `FinalGstarAtDoseGrid`,
143		#'
144		v_pseudo_dual_flex_simulations <- function(object) {
145	!	v <- Validate()
146	!	nSims <- length(object@data)
147	!	v$check(
148	!	identical(length(object@sigma2betaWest), nSims),
149	!	"sigma2betaWest has to have same length as data"
150		)
151	!	v$result()
152		}
153
154		#' @describeIn v_general_simulations validates that the [`DASimulations`] object
155		#' contains valid `trialduration` the vector of trial duration values for all
156		#' simulations.
157
158		v_da_simulations <- function(object) {
159	!	v <- Validate()
160
161	!	nSims <- length(object@data)
162
163	!	v$check(
164	!	identical(length(object@trialduration), nSims),
165	!	"trialduration vector has to have same length as data"
166		)
167
168	!	v$result()
169		}

1		#' Convenience function to make barplots of percentages
2		#'
3		#' @param x vector of samples
4		#' @param description xlab string
5		#' @param xaxisround rounding for xaxis labels (default: 0, i.e. integers will
6		#' be used)
7		#'
8		#' @return the ggplot2 object
9		#'
10		#' @keywords internal
11		#' @importFrom ggplot2 ggplot geom_histogram aes xlab ylab xlim
12		h_barplot_percentages <- function(x, description, xaxisround = 0) {
13	6x	assert_number(xaxisround, lower = 0)
14	4x	assert_character(description, len = 1, any.missing = FALSE)
15	2x	assert_numeric(x)
16
17	1x	tabx <- table(x) / length(x)
18	1x	dat <- data.frame(x = as.numeric(names(tabx)), perc = as.numeric(tabx) * 100)
19	1x	ggplot() +
20	1x	geom_bar(aes(x = x, y = perc),
21	1x	data = dat,
22	1x	stat = "identity",
23	1x	position = "identity",
24	1x	width = ifelse(nrow(dat) > 1, min(diff(dat$x)) / 2, 1)
25		) +
26	1x	xlab(description) +
27	1x	ylab("Percent") +
28	1x	scale_x_continuous(
29	1x	breaks =
30	1x	round(dat$x, xaxisround)
31		)
32		}
33
34
35
36		#' Helper function to calculate percentage of true stopping rules for
37		#' report label output
38		#' calculates true column means and converts output into percentages
39		#' before combining the output with the report label; output is passed
40		#' to [`show()`] and output with cat to console
41		#'
42		#' @param stop_report object from summary method
43		#' @return named list with label and percentage of rule activation
44
45
46		h_calc_report_label_percentage <- function(stop_report) {
47	2x	stop_pct <- colMeans(stop_report) * 100
48	2x	stop_pct_to_print <- stop_pct[!is.na(names(stop_pct))]
49	2x	return(stop_pct_to_print)
50		}
51
52
53
54		#' Helper function to calculate average across iterations for each additional
55		#' reporting parameter
56		#' extracts parameter names as specified by user and averaged the values
57		#' for each specified parameter to [`show()`] and output with cat to console
58		#'
59		#' @param stats_list object from simulation with nested parameter values
60		#' (sublist for each parameter)
61		#' @return list of parameter names and averaged values for console output
62
63
64		h_summarize_add_stats <- function(stats_list) {
65		# Extract the parameter names
66	2x	param_names <- names(stats_list[[1]])
67
68		# Calculate the average for each parameter
69	2x	averages <- lapply(param_names, function(param) {
70	4x	values <- sapply(stats_list, function(x) x[[param]])
71	4x	mean(values)
72		})
73
74	2x	return(list(param_names, averages))
75		}

1		#' Helper Function to Set and Save the RNG Seed
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' This code is basically copied from `stats:::simulate.lm`.
6		#'
7		#' @param seed an object specifying if and how the random number generator
8		#' should be initialized ("seeded"). Either `NULL` (default) or an
9		#' integer that will be used in a call to [set.seed()] before
10		#' simulating the response vectors. If set, the value is saved as the
11		#' `seed` slot of the returned object. The default, `NULL` will
12		#' not change the random generator state.
13		#' @return The integer vector containing the random number generate state will
14		#' be returned, in order to call this function with this input to reproduce
15		#' the obtained simulation results.
16		#'
17		#' @export
18		set_seed <- function(seed = NULL) {
19	35x	assert_number(seed, null.ok = TRUE)
20
21	35x	if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
22	!	runif(1)
23		}
24
25	35x	if (is.null(seed)) {
26	4x	get(".Random.seed", envir = .GlobalEnv)
27		} else {
28	31x	seed <- as.integer(seed)
29	31x	r_seed <- get(".Random.seed", envir = .GlobalEnv)
30		# Make sure r_seed exists in parent frame.
31	31x	assign(".r_seed", r_seed, envir = parent.frame())
32	31x	set.seed(seed)
33		# Here we need the r_seed in the parent.frame!
34	31x	do.call(
35	31x	"on.exit",
36	31x	list(quote(assign(".Random.seed", .r_seed, envir = .GlobalEnv))),
37	31x	envir = parent.frame()
38		)
39	31x	structure(seed, kind = as.list(RNGkind()))
40		}
41		}
42
43		#' Helper Function to Obtain Simulation Results List
44		#'
45		#' The function `fun` can use variables that are visible to itself.
46		#' The names of these variables have to be given in the vector `vars`.
47		#'
48		#' @param fun (`function`)\cr the simulation function for a single iteration, which takes as
49		#' single parameter the iteration index.
50		#' @param nsim number of simulations to be conducted.
51		#' @param vars names of the variables.
52		#' @param parallel should the simulation runs be parallelized across the
53		#' clusters of the computer?
54		#' @param n_cores how many cores should be used for parallel computing?
55		#' @return The list with all simulation results (one iteration corresponds
56		#' to one list element).
57		#'
58		#' @importFrom parallel makeCluster
59		#' @importFrom parallelly availableCores
60		#' @keywords internal programming
61		get_result_list <- function(
62		fun,
63		nsim,
64		vars,
65		parallel,
66		n_cores) {
67	35x	assert_flag(parallel)
68	34x	assert_integerish(n_cores, lower = 1)
69
70	33x	if (!parallel) {
71	33x	lapply(
72	33x	X = seq_len(nsim),
73	33x	FUN = fun
74		)
75		} else {
76		# Process all simulations.
77	!	cores <- min(
78	!	as.integer(n_cores),
79	!	parallelly::availableCores()
80		)
81
82		# Start the cluster.
83	!	cl <- parallel::makeCluster(cores)
84
85		# Load the required R package.
86	!	parallel::clusterEvalQ(cl, {
87	!	library(crmPack)
88	!	NULL
89		})
90
91		# Export local variables from the caller environment.
92		# Note: parent.frame() is different from parent.env() which returns
93		# the environment where this function has been defined!
94	!	parallel::clusterExport(
95	!	cl = cl,
96	!	varlist = vars,
97	!	envir = parent.frame()
98		)
99
100		# Export all global variables.
101	!	parallel::clusterExport(
102	!	cl = cl,
103	!	varlist = ls(.GlobalEnv)
104		)
105
106		# Load user extensions from global options.
107	!	crmpack_extensions <- getOption("crmpack_extensions")
108	!	if (is.null(crmpack_extensions) != TRUE) {
109	!	tryCatch(
110		{
111	!	parallel::clusterCall(cl, crmpack_extensions)
112		},
113	!	error = function(e) {
114	!	stop("Failed to export crmpack_extensions: ", e$message)
115		}
116		)
117		}
118
119		# Do the computations in parallel.
120	!	res <- parallel::parLapply(
121	!	cl = cl,
122	!	X = seq_len(nsim),
123	!	fun = fun
124		)
125
126		# Stop the cluster.
127	!	parallel::stopCluster(cl)
128
129	!	res
130		}
131		}
132
133
134
135
136		#' Helper Function to call truth calculation
137		#'
138		#' @param dose (`number`)\cr current dose.
139		#' @param truth (`function`)\cr defines the true probability for a DLT at a dose.
140		#' @param this_args (`data.frame`)\cr list of arguments for the truth.
141		#' @return The updated `this_truth`.
142		#'
143		#' @keywords internal
144		h_this_truth <- function(dose, this_args, truth) {
145	115x	do.call(
146	115x	truth,
147		## First argument: the dose
148	115x	c(
149	115x	dose,
150		## Following arguments
151	115x	this_args
152		)
153		)
154		}
155
156
157		#' Helper Function to create return list for Simulations output
158		#'
159		#' @param resultList (`list`)\cr raw iteration output.
160		#'
161		#' @return aggregated output for simulation object `list`.
162		#'
163		#' @keywords internal
164		h_simulations_output_format <- function(resultList) {
165		## put everything in the Simulations format:
166
167		## setup the list for the simulated data objects
168	11x	dataList <- lapply(resultList, "[[", "data")
169
170		## the vector of the final dose recommendations
171	11x	recommendedDoses <- as.numeric(sapply(resultList, "[[", "dose"))
172
173		## setup the list for the final fits
174	11x	fitList <- lapply(resultList, "[[", "fit")
175
176		## the reasons for stopping
177	11x	stopReasons <- lapply(resultList, "[[", "stop")
178
179		# individual stopping rule results as matrix, labels as column names
180	11x	stopResults <- lapply(resultList, "[[", "report_results")
181	11x	stop_matrix <- as.matrix(do.call(rbind, stopResults))
182
183		# Result list of additional statistical summary.
184	11x	additional_stats <- lapply(resultList, "[[", "additional_stats")
185
186	11x	return(list(
187	11x	dataList = dataList,
188	11x	recommendedDoses = recommendedDoses,
189	11x	fitList = fitList,
190	11x	stopReasons = stopReasons,
191	11x	stopResults = stopResults,
192	11x	additional_stats = additional_stats,
193	11x	stop_matrix = stop_matrix
194		))
195		}
196
197
198		#' Helper function to recursively unpack stopping rules and return lists with
199		#' logical value and label given
200		#'
201		#' @param stopit_tree object from simulate method
202		#' @return named list
203
204		h_unpack_stopit <- function(stopit_tree) {
205	813x	label <- attr(stopit_tree, "report_label")
206	813x	value <- stopit_tree[1]
207	813x	names(value) <- label
208	813x	value
209	813x	if (is.null(attr(stopit_tree, "individual"))) {
210	602x	return(value)
211		} else {
212	211x	return(unlist(c(value, lapply(attr(stopit_tree, "individual"), h_unpack_stopit))))
213		}
214		}
215
216
217
218		#' Helper function to determine the dlts including first separate and placebo
219		#' condition
220		#'
221		#' @param data (`Data`)\cr what data to start from.
222		#' @param dose (`number`)\cr current dose.
223		#' @param prob (`function`)\cr defines the true probability for a DLT at a dose.
224		#' @param prob_placebo (`function`)\cr defines the true probability for a DLT at a placebo condition.
225		#' @param cohort_size (`number`)\cr the cohort size to use.
226		#' @param cohort_size_placebo (`number`)\cr the cohort size to use for placebo condition.
227		#' @param dose_grid (`numeric`)\cr the dose_grid as specified by the user.
228		#' @param first_separate (`flag`)\cr whether the first patient is enrolled separately.
229		#' @return updated data object
230		#' @keywords internal
231
232
233		h_determine_dlts <- function(data,
234		dose,
235		prob,
236		prob_placebo,
237		cohort_size,
238		cohort_size_placebo,
239		dose_grid,
240		first_separate) {
241	235x	assert_class(data, "Data")
242	235x	assert_number(dose)
243	235x	assert_number(prob)
244	235x	assert_number(cohort_size)
245	235x	assert_flag(first_separate)
246
247	235x	if (first_separate && cohort_size > 1) {
248	29x	dlts <- rbinom(n = 1, size = 1, prob = prob)
249	29x	if ((data@placebo) && cohort_size_placebo > 0) {
250	!	dlts_placebo <- rbinom(n = 1, size = 1, prob = prob_placebo)
251		}
252	29x	if (dlts == 0) {
253	16x	dlts <- c(dlts, rbinom(n = cohort_size - 1L, size = 1, prob = prob))
254	16x	if ((data@placebo) && cohort_size_placebo > 0) {
255	!	dlts_placebo <- c(dlts_placebo, rbinom(
256	!	n = cohort_size_placebo, # cohort_size_placebo - 1?
257	!	size = 1,
258	!	prob = prob_placebo
259		))
260		}
261		}
262		} else {
263	206x	dlts <- rbinom(n = cohort_size, size = 1, prob = prob)
264	206x	if ((data@placebo) && cohort_size_placebo > 0) {
265	6x	dlts_placebo <- rbinom(n = cohort_size_placebo, size = 1, prob = prob_placebo)
266		}
267		}
268
269
270	235x	if ((data@placebo) && cohort_size_placebo > 0) {
271	6x	this_data <- update(
272	6x	object = data,
273	6x	x = dose_grid,
274	6x	y = dlts_placebo,
275	6x	check = FALSE
276		)
277
278		## update the data with active dose
279	6x	this_data <- update(
280	6x	object = this_data,
281	6x	x = dose,
282	6x	y = dlts,
283	6x	new_cohort = FALSE
284		)
285		} else {
286		## update the data with this cohort
287	229x	this_data <- update(
288	229x	object = data,
289	229x	x = dose,
290	229x	y = dlts
291		)
292		}
293	235x	return(this_data)
294		}

1		# Integration with knitr ----
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' We provide additional utility functions to allow human-friendly rendition of
6		#' crmPack objects in Markdown and Quarto files
7		#'
8		#' @return a character string that represents the object in markdown.
9		#' @name knit_print
10		NULL
11
12		# CohortSize ----
13
14		#' Render a `CohortSizeConst` Object
15		#'
16		#' @description `r lifecycle::badge("experimental")`
17		#' @param x (`CohortSize`)\cr The object to knit_print.
18		#' @param asis (`flag`)\cr Should the return value be wrapped in a call to `knitr::asis_output`?
19		#' @param label (`character`)\cr The word used to label the participants. See Usage Notes below.
20		#' @param ... Not used at present
21		#'
22		#' @section Usage Notes:
23		#' `label` describes the trial's participants.
24		#'
25		#' It should be a character vector of length 1 or 2. If of length 2, the first
26		#' element describes a `cohort_size` of 1 and the second describes all other
27		#' `cohort_size`s. If of length 1, the character `s` is appended to the value
28		#' when `cohort_size` is not 1.
29		#' @return The markdown representation of the object, as a character string
30		#' @seealso [`knit_print`] for more details.
31		#'
32		#' @export
33		#' @rdname knit_print
34		knit_print.CohortSizeConst <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
35	9x	assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
36	9x	assert_flag(asis)
37
38	7x	if (length(label) == 1) {
39	2x	label[2] <- paste0(label[1], "s")
40		}
41	7x	rv <- paste0("A constant size of ", x@size, " ", label[ifelse(x@size == 1, 1, 2)], ".")
42	7x	if (asis) {
43	5x	rv <- knitr::asis_output(rv)
44		}
45	7x	rv
46		}
47
48		#' Render a `CohortSizeRange` Object
49		#'
50		#' @description `r lifecycle::badge("experimental")`
51		#' @param ... passed to `knitr::kable`
52		#' @inherit knit_print.CohortSizeConst return
53		#' @section Usage Notes:
54		#' The default value of `col.names` is `c("Lower", "Upper", "Cohort size")` and
55		#' that of `caption` is `"Defined by the dose to be used in the next cohort"`.
56		#' These values can be overridden by passing `col.names` and `caption` in the
57		#' function call.
58		#' @export
59		#' @rdname knit_print
60		knit_print.CohortSizeRange <- function(x, ..., asis = TRUE) {
61	14x	assert_flag(asis)
62
63	12x	param <- list(...)
64	12x	if (!("col.names" %in% names(param))) {
65	12x	param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
66		}
67	12x	if (!("caption" %in% names(param))) {
68	12x	param[["caption"]] <- "Defined by the dose to be used in the next cohort"
69		}
70	12x	x <- tidy(x)
71	12x	param[["x"]] <- x
72	12x	rv <- kableExtra::add_header_above(
73	12x	do.call(knitr::kable, param),
74	12x	c("Dose" = 2, " " = 1)
75		)
76	12x	if (asis) {
77	8x	rv <- knitr::asis_output(rv)
78		}
79	12x	rv
80		}
81
82		#' Render a `CohortSizeDLT` Object
83		#'
84		#' @description `r lifecycle::badge("experimental")`
85		#' @inherit knit_print.CohortSizeConst return
86		#' @param ... Passed to [knitr::kable()].
87		#'
88		#' @section Usage Notes:
89		#' The by default, the columns are labelled `Lower`, `Upper` and `Cohort size`. The table's caption is
90		#' `Defined by the number of DLTs so far observed`. These values can be overridden by passing
91		#' `col.names` and `caption` in the function call.
92		#'
93		#' @export
94		#' @rdname knit_print
95		knit_print.CohortSizeDLT <- function(x, ..., asis = TRUE) {
96	11x	assert_flag(asis)
97
98	9x	param <- list(...)
99	9x	if (!("col.names" %in% names(param))) {
100	9x	param[["col.names"]] <- c("Lower", "Upper", "Cohort size")
101		}
102	9x	if (!("caption" %in% names(param))) {
103	9x	param[["caption"]] <- "Defined by the number of DLTs so far observed"
104		}
105	9x	param[["x"]] <- tidy(x)
106	9x	rv <- kableExtra::add_header_above(
107	9x	do.call(knitr::kable, param),
108	9x	c("No of DLTs" = 2, " " = 1)
109		)
110	9x	if (asis) {
111	6x	rv <- knitr::asis_output(rv)
112		}
113	9x	rv
114		}
115
116		#' Render a `CohortSizeParts` Object
117		#'
118		#' @description `r lifecycle::badge("experimental")`
119		#' @inherit knit_print.CohortSizeConst return
120		#' @inheritSection knit_print.CohortSizeConst Usage Notes
121		#'
122		#' @export
123		#' @rdname knit_print
124		knit_print.CohortSizeParts <- function(x, ..., asis = TRUE, label = c("participant", "participants")) {
125	9x	assert_character(label, min.len = 1, max.len = 2, any.missing = FALSE)
126	9x	assert_flag(asis)
127
128	7x	if (length(label) == 1) {
129	2x	label[2] <- paste0(label[1], "s")
130		}
131	7x	rv <- paste0(
132	7x	"A size of ",
133	7x	x@cohort_sizes[1],
134		" ",
135	7x	label[ifelse(x@cohort_sizes[1] == 1, 1, 2)],
136	7x	" in the first part and ",
137	7x	x@cohort_sizes[2],
138		" ",
139	7x	label[ifelse(x@cohort_sizes[2] == 1, 1, 2)],
140	7x	" in the second."
141		)
142	7x	if (asis) {
143	5x	rv <- knitr::asis_output(rv)
144		}
145	7x	rv
146		}
147
148		#' Render a `CohortSizeMax` Object
149		#'
150		#' @description `r lifecycle::badge("experimental")`
151		#' @inherit knit_print.CohortSizeConst return
152		#' @param ... passed through to the `knit_print` methods of the constituent
153		#' rules
154		#'
155		#' @export
156		#' @rdname knit_print
157		knit_print.CohortSizeMax <- function(x, ..., asis = TRUE) {
158	5x	assert_flag(asis)
159	3x	rv <- paste0(
160	3x	"The maximum of the cohort sizes defined in the following rules:",
161	3x	paste0(
162	3x	lapply(
163	3x	x@cohort_sizes,
164	3x	function(x, ...) {
165	6x	knit_print(x, asis = asis, ...)
166		}
167		),
168	3x	collapse = "\n"
169		),
170	3x	paste = "\n"
171		)
172
173	3x	if (asis) {
174	2x	rv <- knitr::asis_output(rv)
175		}
176	3x	rv
177		}
178
179		#' Render a `CohortSizeMin` Object
180		#'
181		#' @description `r lifecycle::badge("experimental")`
182		#' @inherit knit_print.CohortSizeConst return
183		#' @param ... passed through to the `knit_print` methods of the constituent
184		#' rules
185		#'
186		#' @export
187		#' @rdname knit_print
188		knit_print.CohortSizeMin <- function(x, ..., asis = TRUE) {
189	5x	assert_flag(asis)
190	3x	rv <- paste0(
191	3x	"The minimum of the cohort sizes defined in the following rules:",
192	3x	paste0(
193	3x	lapply(
194	3x	x@cohort_sizes,
195	3x	function(x, ...) {
196	6x	knit_print(x, asis = asis, ...)
197		}
198		),
199	3x	collapse = "\n"
200		),
201	3x	paste = "\n"
202		)
203	3x	if (asis) {
204	2x	rv <- knitr::asis_output(rv)
205		}
206	3x	rv
207		}
208
209		#' Render a `CohortSizeOrdinal` Object
210		#'
211		#' @description `r lifecycle::badge("experimental")`
212		#' @inherit knit_print.CohortSizeConst return
213		#' @param ... passed through to the `knit_print` method of the standard rule
214		#'
215		#' @export
216		#' @rdname knit_print
217		knit_print.CohortSizeOrdinal <- function(x, ..., asis = TRUE) {
218	5x	assert_flag(asis)
219
220	3x	rv <- paste0(
221	3x	"Based on a toxicity grade of ",
222	3x	x@grade,
223		": ",
224	3x	paste0(knit_print(x@rule, asis = asis, ...), collapse = "\n"),
225	3x	paste = "\n"
226		)
227
228	3x	if (asis) {
229	2x	rv <- knitr::asis_output(rv)
230		}
231	3x	rv
232		}

1		#' Convert a Samples Object from an ordinal Model to the Equivalent Samples Object
2		#' from a Binary Model
3		#'
4		#' @description `r lifecycle::badge("experimental")`
5		#'
6		#' A simple helper function that converts a [`Samples`] object from the fit of an
7		#' ordinal CRM model to that which would have been obtained from fitting a binary
8		#' CRM model for toxicities of a specified grade to the same observed data.
9		#'
10		#' @param obj (`Samples`)\cr the `Samples` object to covert
11		#' @param grade (`integer`)\cr the toxicity grade for which the equivalent data
12		#' is required.
13		#' @return A [`Samples`] object.
14		#'
15		#' @export
16		h_convert_ordinal_samples <- function(obj, grade) {
17		# Validate
18	27x	assert_integer(grade, len = 1, lower = 1)
19	25x	assert_class(obj, "Samples")
20	24x	assert_subset(c(paste0("alpha", 1:grade), "beta"), names(obj@data))
21		# Execute
22	23x	d <- list("alpha0" = obj@data[[paste0("alpha", grade)]], "alpha1" = obj@data$beta)
23	23x	Samples(data = d, options = obj@options)
24		}

1		# assertions ----
2
3		#' Additional Assertions for `checkmate`
4		#'
5		#' @description `r lifecycle::badge("experimental")`
6		#'
7		#' We provide additional assertion functions that can be used together with
8		#' the `checkmate` functions. These are described in individual help pages
9		#' linked below.
10		#'
11		#' @return Depending on the function prefix.
12		#' - `assert_` functions return the object invisibly if successful, and otherwise
13		#' throw an error message.
14		#' - `check_` functions return `TRUE` if successful, otherwise a string with the
15		#' error message.
16		#' - `test_` functions just return `TRUE` or `FALSE`.
17		#'
18		#' @seealso [assert_probabilities()], [assert_probability()],
19		#' [assert_probability_range()], [assert_length()].
20		#'
21		#' @name assertions
22		NULL
23
24		# check equality ----
25
26		#' Check if All Arguments Are Equal
27		#'
28		#' @description `r lifecycle::badge("experimental")`
29		#' Elements of `...` must be numeric vectors or scalars.
30		#'
31		#' This function performs an element-by-element comparison of the first object
32		#' provided in `...` with every other object in `...` and returns `TRUE` if all
33		#' comparisons are equal within a given tolerance and `FALSE` otherwise.
34		#'
35		#' @param ... (`numeric`)\cr vectors to be compared.
36		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
37		#' judging equality.
38		#'
39		#' @note If there are any missing or infinite values in `...`, this function
40		#' returns `FALSE`, regardless of the values of other elements in `...`.
41		#'
42		#' @note If elements in `...` are not all of the same length, `FALSE` is returned.
43		#'
44		#' @return `TRUE` if all element-by-element differences are less than `tolerance`
45		#' in magnitude, `FALSE` otherwise.
46		#' @seealso [`assertions`] for more details.
47		#'
48		#' @export
49		#' @examples
50		#' check_equal(1:2, 1:2) # TRUE
51		#' check_equal(1:2, 2:3) # "Not all equal"
52		#' check_equal(Inf, Inf) # "Not all equal"
53		#' check_equal(0.01, 0.02) # "Not all equal"
54		#' check_equal(0.01, 0.02, tol = 0.05) # TRUE
55		#' check_equal(1, c(1, 1)) # "Not all equal"
56		check_equal <- function(..., tol = sqrt(.Machine$double.eps)) {
57	14x	dot_args <- list(...)
58
59	14x	sapply(dot_args, assert_numeric)
60
61	14x	tmp <- sapply(dot_args, length)
62	14x	if (min(tmp) != max(tmp)) {
63	2x	return("Not all of same length")
64		}
65	12x	if (any(sapply(dot_args, is.na))) {
66	2x	return("Some entries NA")
67		}
68	10x	if (any(sapply(dot_args, is.infinite))) {
69	2x	return("Not all entries finite")
70		}
71	8x	if (!all(sapply(dot_args, test_numeric))) {
72	!	return("Not all numeric")
73		}
74
75	8x	all_ok <- test_true(
76	8x	all(
77	8x	sapply(
78	8x	2:length(dot_args),
79	8x	function(z) abs(dot_args[[1]] - dot_args[[z]]) < tol
80		)
81		)
82		)
83	8x	if (all_ok) {
84	4x	return(TRUE)
85		}
86	4x	"Not all equal"
87		}
88
89		#' Assert That All Arguments Are Equal
90		#'
91		#' @description `r lifecycle::badge("experimental")`
92		#' Elements of `...` must be numeric vectors or scalars.
93		#'
94		#' This function performs an element-by-element comparison of the first object
95		#' provided in `...` with every other object in `...` and throws an error if they
96		#' are not.
97		#'
98		#' @param ... (`numeric`)\cr vectors to be compared
99		#' @param tol (`numeric`)\cr the maximum difference to be tolerated when
100		#' judging equality
101		#'
102		#' @note If there are any missing or infinite values in `...`, this function
103		#' throws an error, regardless of the values of other elements in `...`.
104		#'
105		#' @note If elements in `...` are not all of the same length, an error is thrown.
106		#'
107		#' @return `list(...)`, invisibly.
108		#' @seealso [`assertions`] for more details.
109		#' @inheritParams checkmate::assert_numeric
110		#'
111		#' @export
112		#' @rdname check_equal
113		#' @examples
114		#' assert_equal(1:2, 1:2) # no error
115		#' assert_equal(0.01, 0.02, tol = 0.05) # no error
116		# nolint start
117		assert_equal <- function(..., tol = sqrt(.Machine$double.eps), .var.name = vname(x), add = NULL) {
118		# assert_equal <- makeAssertionFunction(check_equal) fails with error "Error
119		# in `checkmate::makeAssertion(..., res, .var.name, add)`: unused argument
120		# (add)", possibly because of the use of ... in check_equal.
121	7x	res <- check_equal(..., tol = tol)
122	7x	makeAssertion(list(...), res, .var.name, add)
123		}
124		# nolint end
125
126		# assert_probabilities ----
127
128		#' Check if an argument is a probability vector
129		#'
130		#' @description `r lifecycle::badge("stable")`
131		#'
132		#' Check if every element in a given numerical vector or matrix represents a
133		#' probability, that is a number within (0, 1) interval, that can optionally be
134		#' closed at any side.
135		#'
136		#' @note If there are any missing or non-finite values in `x`, this function
137		#' returns `FALSE`, regardless of the values of other elements in `x`.
138		#'
139		#' @param x (`numeric`)\cr vector or matrix with numerical values to check.
140		#' @param bounds_closed (`logical`)\cr should bounds be closed? This can be a
141		#' scalar or vector of length two. If it is a scalar, then its value applies
142		#' equally to lower bound \eqn{0} and upper bound \eqn{1}. If this is a vector
143		#' with two flags, the first flag corresponds to the lower bound \eqn{0}
144		#' only, and the second to the upper bound \eqn{1} only.
145		#' @inheritParams checkmate::check_numeric
146		#'
147		#' @return `TRUE` if successful, otherwise a string with the error message.
148		#'
149		#' @seealso [`assertions`] for more details.
150		#'
151		#' @export
152		#' @examples
153		#' x <- c(0, 0.2, 0.1, 0.3, 1)
154		#' check_probabilities(x)
155		#' check_probabilities(x, bounds_closed = FALSE)
156		#' check_probabilities(x, bounds_closed = c(FALSE, TRUE))
157		check_probabilities <- function(x, bounds_closed = TRUE, len = NULL, unique = FALSE, sorted = FALSE) {
158	10417x	assert_numeric(x)
159	10416x	assert_logical(bounds_closed, min.len = 1, max.len = 2, any.missing = FALSE)
160	10416x	assert_number(len, null.ok = TRUE)
161	10416x	assert_flag(sorted)
162
163	10416x	result <- check_numeric(
164	10416x	x,
165	10416x	finite = TRUE, any.missing = FALSE, len = len, unique = unique, sorted = sorted
166		)
167
168	10416x	if (isTRUE(result)) {
169	10338x	in_bounds <- all(h_in_range(x, range = c(0L, 1L), bounds_closed = bounds_closed))
170	10338x	if (!in_bounds) {
171	140x	result <- paste(
172	140x	"Probability must be within",
173	140x	ifelse(bounds_closed[1], "[0,", "(0,"),
174	140x	ifelse(tail(bounds_closed, 1), "1]", "1)"),
175	140x	"bounds but it is not"
176		)
177		}
178		}
179
180	10416x	result
181		}
182
183		#' @rdname check_probabilities
184		#' @inheritParams check_probabilities
185		#' @export
186		assert_probabilities <- makeAssertionFunction(check_probabilities)
187
188		#' @rdname check_probabilities
189		#' @inheritParams check_probabilities
190		#' @export
191		test_probabilities <- makeTestFunction(check_probabilities)
192
193		#' @rdname check_probabilities
194		#' @inheritParams check_probabilities
195		#' @export
196		expect_probabilities <- makeExpectationFunction(check_probabilities)
197
198		# assert_probability ----
199
200		#' Check if an argument is a single probability value
201		#'
202		#' @description `r lifecycle::badge("stable")`
203		#'
204		#' Check if a given value represents a probability, that is a number within
205		#' (0, 1) interval, that can optionally be closed at any side.
206		#'
207		#' @param x (`number`)\cr a single value to check.
208		#' @inheritParams check_probabilities
209		#'
210		#' @return `TRUE` if successful, otherwise a string with the error message.
211		#'
212		#' @seealso [`assertions`] for more details.
213		#'
214		#' @export
215		#' @examples
216		#' check_probability(0.5)
217		#' check_probability(0, bounds_closed = FALSE)
218		#' check_probability(0, bounds_closed = c(FALSE, TRUE))
219		check_probability <- function(x, bounds_closed = TRUE) {
220	5565x	check_probabilities(x = x, bounds_closed = bounds_closed, len = 1)
221		}
222
223		#' @rdname check_probability
224		#' @inheritParams check_probability
225		#' @export
226		assert_probability <- makeAssertionFunction(check_probability)
227
228		#' @rdname check_probability
229		#' @inheritParams check_probability
230		#' @export
231		test_probability <- makeTestFunction(check_probability)
232
233		#' @rdname check_probability
234		#' @inheritParams check_probability
235		#' @export
236		expect_probability <- makeExpectationFunction(check_probability)
237
238		# assert_probability_range ----
239
240		#' Check if an argument is a probability range
241		#'
242		#' @description `r lifecycle::badge("stable")`
243		#'
244		#' Check if a given numerical interval represents a probability range, that is
245		#' a sub-interval of (0, 1) interval, that can optionally be closed at any side.
246		#'
247		#' @param x (`number`)\cr an interval to check.
248		#' @inheritParams check_probabilities
249		#'
250		#' @return `TRUE` if successful, otherwise a string with the error message.
251		#'
252		#' @seealso [`assertions`] for more details.
253		#'
254		#' @export
255		#' @examples
256		#' x <- c(0, 0.2)
257		#' check_probability_range(x)
258		#' check_probability_range(rev(x))
259		#' check_probability_range(x, bounds_closed = FALSE)
260		#' check_probability_range(x, bounds_closed = c(FALSE, TRUE))
261		check_probability_range <- function(x, bounds_closed = TRUE) {
262	753x	check_probabilities(x = x, bounds_closed = bounds_closed, len = 2, sorted = TRUE)
263		}
264
265		#' @rdname check_probability_range
266		#' @inheritParams check_probability_range
267		#' @export
268		assert_probability_range <- makeAssertionFunction(check_probability_range)
269
270		#' @rdname check_probability_range
271		#' @inheritParams check_probability_range
272		#' @export
273		test_probability_range <- makeTestFunction(check_probability_range)
274
275		#' @rdname check_probability_range
276		#' @inheritParams check_probability_range
277		#' @export
278		expect_probability_range <- makeExpectationFunction(check_probability_range)
279
280		# assert_length ----
281
282		#' Check if vectors are of compatible lengths
283		#'
284		#' @description `r lifecycle::badge("stable")`
285		#'
286		#' Two vectors are of compatible size if and only if: \cr
287		#' 1. At least one vector has size 1 \cr
288		#' 2. or both vectors are of the same size. \cr
289		#'
290		#' @param x (`any`)\cr the first vector, any object for which [length()]
291		#' function is defined.
292		#' @param len (`count`)\cr the length of the second vector.
293		#' @inheritParams checkmate::check_numeric
294		#'
295		#' @return `TRUE` if successful, otherwise a string with the error message.
296		#'
297		#' @seealso [`assertions`] for more details.
298		#'
299		#' @export
300		#' @examples
301		#' check_length(1:5, 1)
302		#' check_length(1:5, 6)
303		#' check_length(1:5, 5)
304		#' check_length(10, 1)
305		#' check_length(10, 9)
306		check_length <- function(x, len) {
307	46887x	x_len <- length(x)
308	46887x	assert_true(x_len >= 1L)
309	46886x	assert_count(len)
310
311	46882x	if (x_len == 1L \|\| len == 1L \|\| x_len == len) {
312	46853x	TRUE
313		} else {
314	29x	paste(
315	29x	"x is of length",
316	29x	x_len,
317	29x	"which is not allowed; the allowed lengths are: 1 or",
318	29x	len,
319	29x	collapse = ""
320		)
321		}
322		}
323
324		#' @rdname check_length
325		#' @inheritParams check_length
326		#' @export
327		assert_length <- makeAssertionFunction(check_length)
328
329		#' @rdname check_length
330		#' @inheritParams check_length
331		#' @export
332		test_length <- makeTestFunction(check_length)
333
334		# assert_range ----
335
336		#' Check that an argument is a numerical range
337		#'
338		#' @description `r lifecycle::badge("stable")`
339		#'
340		#' An argument `x` is a numerical range if and only if (all conditions must be met):
341		#' 1. Is an object of type: `integer` or `double`.
342		#' 2. Is a vector or length two such that the value of the first number is not
343		#' less than the second number. Equalness is allowed if and only if `unique` flag
344		#' is set to `TRUE`.
345		#' 3. Lower bound of the interval is greater than or equal to `lower` and
346		#' upper bound of the interval is less than or equal to `upper`.
347		#' 4. It contains only finite (given that `finite` is `TRUE`) and non-missing values.
348		#'
349		#' @inheritParams checkmate::check_numeric
350		#'
351		#' @return `TRUE` if successful, otherwise a string with the error message.
352		#'
353		#' @seealso [`assertions`] for more details.
354		#'
355		#' @export
356		#' @examples
357		#' check_range(c(1, 5))
358		#' check_range(c(-5, 1))
359		#' check_range(c(4, 1))
360		#' check_range(c(1, 1))
361		#' check_range(c(1, 1), unique = FALSE)
362		#' check_range(1:3)
363		check_range <- function(x, lower = -Inf, upper = Inf, finite = FALSE, unique = TRUE) {
364	92x	assert_number(lower)
365	91x	assert_number(upper)
366	90x	assert_flag(finite)
367	89x	assert_flag(unique)
368
369	88x	result <- check_numeric(
370	88x	x,
371	88x	lower = lower,
372	88x	upper = upper,
373	88x	finite = finite,
374	88x	any.missing = FALSE,
375	88x	len = 2,
376	88x	unique = unique,
377	88x	sorted = TRUE
378		)
379
380	88x	if (!isTRUE(result)) {
381	24x	result <- paste("x must be a valid numerical range.", result)
382		}
383	88x	result
384		}
385
386		#' @rdname check_range
387		#' @inheritParams check_range
388		#' @export
389		assert_range <- makeAssertionFunction(check_range)
390
391		#' @rdname check_range
392		#' @inheritParams check_range
393		#' @export
394		test_range <- makeTestFunction(check_range)
395
396		#' @rdname check_range
397		#' @inheritParams check_range
398		#' @export
399		expect_range <- makeExpectationFunction(check_range)
400
401		# assert_format ----
402
403		#' Check that an argument is a valid format specification
404		#'
405		#' @description `r lifecycle::badge("stable")`
406		#'
407		#' @inheritParams checkmate::check_numeric
408		#'
409		#' @return `TRUE` if successful, otherwise a string with the error message.
410		#'
411		#' @seealso [`assertions`] for more details.
412		#'
413		#' @export
414		#' @examples
415		#' check_format("%5.2f")
416		check_format <- function(x, len = NULL, min.len = NULL, max.len = NULL) {
417	122x	assert_number(len, lower = 1, null.ok = TRUE)
418	122x	assert_number(min.len, lower = 1, null.ok = TRUE)
419	122x	assert_number(max.len, lower = 1, null.ok = TRUE)
420
421	122x	result <- check_character(
422	122x	x,
423	122x	len = len,
424	122x	min.len = min.len,
425	122x	max.len = max.len,
426	122x	any.missing = FALSE,
427		# https://stackoverflow.com/questions/446285/validate-sprintf-format-from-input-field-with-regex
428	122x	pattern = "%(?:\\d+\\$)?[+-]?(?:[ 0]\|'.{1})?-?\\d*(?:\\.\\d+)?[bcdeEufFgGosxX]",
429		)
430
431	122x	if (!isTRUE(result)) {
432	!	result <- paste("x must be a valid format specifier.", result)
433		}
434	122x	result
435		}
436
437		#' @rdname check_format
438		#' @inheritParams check_format
439		#' @export
440		assert_format <- makeAssertionFunction(check_format)
441
442		#' @rdname check_format
443		#' @inheritParams check_format
444		#' @export
445		test_format <- makeTestFunction(check_format)
446
447		#' @rdname check_format
448		#' @inheritParams check_format
449		#' @export
450		expect_format <- makeExpectationFunction(check_format)

1		# v_mcmc_options ----
2
3		#' Internal Helper Functions for Validation of [`McmcOptions`] Objects
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' These functions are only used internally to validate the format of an input
8		#' [`McmcOptions`] or inherited classes and therefore not exported.
9		#'
10		#' @name v_mcmcoptions_objects
11		#' @param object (`McmcOptions`)\cr object to validate.
12		#' @return A `character` vector with the validation failure messages,
13		#' or `TRUE` in case validation passes.
14		NULL
15
16		#' @describeIn v_mcmcoptions_objects validates that the [`McmcOptions`]
17		#' object contains valid integer scalars `iterations`, `burnin` and `step`
18		#' as well as proper parameters for Random Number Generator.
19		v_mcmc_options <- function(object) {
20	4x	v <- Validate()
21	4x	allowed_rng_kinds <- c(
22	4x	"base::Wichmann-Hill",
23	4x	"base::Marsaglia-Multicarry",
24	4x	"base::Super-Duper",
25	4x	"base::Mersenne-Twister",
26	4x	NA_character_
27		)
28
29	4x	v$check(
30	4x	test_int(object@iterations, lower = 1L),
31	4x	"iterations must be integer scalar greater than or equal to 1"
32		)
33	4x	v$check(
34	4x	test_int(object@burnin, lower = 0L),
35	4x	"burn-in must be non-negative integer scalar"
36		)
37		# This below check should not be conducted in above test, using
38		# `upper = object@iterations -1` argument, since object@iterations might be
39		# not-valid. In such a case `test_int` throws an internal error.
40	4x	v$check(
41	4x	test_true(object@burnin < object@iterations),
42	4x	"burn-in must be lower than iterations"
43		)
44	4x	v$check(
45	4x	test_int(object@step, lower = 1L),
46	4x	"step must be integer scalar greater than or equal to 1"
47		)
48
49	4x	is_rng_kind_scalar <- test_string(object@rng_kind, na.ok = TRUE)
50	4x	v$check(is_rng_kind_scalar, "rng_kind must be a single string")
51	4x	v$check(
52	4x	test_subset(object@rng_kind, allowed_rng_kinds),
53	4x	paste0(
54	4x	"rng_kind must one of the following: ",
55	4x	paste(allowed_rng_kinds, collapse = ", "),
56	4x	". User specifies the rng_kind without `base::` prefix"
57		)
58		)
59
60	4x	is_rng_seed_scalar <- test_int(object@rng_seed, na.ok = TRUE)
61	4x	v$check(is_rng_seed_scalar, "rng_seed must be an integer scalar")
62
63		# Below `if` condition is not only reasonable but also needed as R CMD check
64		# is activating some stricter checks and it fails when arguments to `\|\|` are
65		# not scalars, even if `\|\|` works well with vectors of length > 1.
66	4x	if (is_rng_kind_scalar && is_rng_seed_scalar) {
67	3x	v$check(
68	3x	!is.na(object@rng_kind) \|\| is.na(object@rng_seed),
69	3x	"rng_seed supplied but rng_kind not set"
70		)
71		}
72	4x	v$result()
73		}

1		# tidy ----
2
3		## generic ----
4
5		#' Tidying `CrmPackClass` objects
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#'
9		#' In the spirit of the `broom` package, provide a method to convert a
10		#' `CrmPackClass` object to a (list of) tibbles.
11		#'
12		#' @param x (`CrmPackClass`)\cr the object to be tidied.
13		#' @param ... potentially used by class-specific methods
14		#'
15		#' @return A (list of) tibble(s) representing the object in tidy form.
16		#'
17		#' @export
18		#'
19		setGeneric(
20		name = "tidy",
21		def = function(x, ...) {
22	649x	standardGeneric("tidy")
23		}
24		)
25
26		## CrmPackClass ----
27
28		#' Tidy a `CrmPackClass` Object
29		#'
30		#' Following the principles of the `broom` package, convert a `CrmPackClass`
31		#' object to a (list of) tibbles. This is a basic, default representation.
32		#'
33		#' @param x (`CrmPackClass`)\cr the object to be tidied.
34		#' @param ... potentially used by class-specific methods.
35		#' @rdname tidy
36		#' @aliases tidy-CrmPackClass
37		#' @keywords methods
38		#' @example examples/CrmPackClass-method-tidy.R
39		#'
40		#' @export
41		setMethod(
42		f = "tidy",
43		signature = signature(x = "CrmPackClass"),
44		definition = function(x, ...) {
45	392x	rv <- h_tidy_all_slots(x) %>% h_tidy_class(x)
46	392x	if (length(rv) == 1) {
47	75x	rv[[names(rv)[1]]] %>% h_tidy_class(x)
48		} else {
49	317x	rv
50		}
51		}
52		)

1		#' Verbose Logging
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' A family of wrappers of selected [`futile.logger`] functions that control
6		#' the logging mechanism in `crmPack`. The `crmPack` uses [`futile.logger`]
7		#' package for the logging purposes. All the messages logged in `crmPack` are
8		#' logged into `crmPack` logger at the [`futile.logger::TRACE`] level. Hence,
9		#' enabling verbose logging means that the logging threshold will be set to
10		#' [`futile.logger::TRACE`] for the `crmPack` logger, and disabling verbose
11		#' logging means that it will be set to [`futile.logger::FATAL`].
12		#'
13		#' @describeIn enable_logging A simple wrapper of
14		#' [futile.logger::flog.threshold()] that enables `crmPack` verbose logging by
15		#' setting logging threshold to [`futile.logger::TRACE`] for `crmPack` logger.
16		#'
17		#' @export
18		#'
19		enable_logging <- function() {
20	3x	invisible(
21	3x	futile.logger::flog.threshold(futile.logger::TRACE, name = "crmPack")
22		)
23		}
24
25		#' @describeIn enable_logging A simple wrapper of
26		#' [futile.logger::flog.threshold()] that disables `crmPack` verbose logging
27		#' by setting logging threshold to [`futile.logger::FATAL`] for `crmPack`
28		#' logger.
29		#'
30		#' @export
31		#'
32		disable_logging <- function() {
33	6x	invisible(
34	6x	futile.logger::flog.threshold(futile.logger::FATAL, name = "crmPack")
35		)
36		}
37
38		#' @describeIn enable_logging A simple wrapper of
39		#' [futile.logger::flog.logger()] that checks whether current threshold level
40		#' for `crmPack` logger is verbose, which is [`futile.logger::TRACE`].
41		#' It returns `TRUE` if the current logging level is verbose, `FALSE`
42		#' otherwise.
43		#'
44		#' @export
45		#'
46		is_logging_enabled <- function() {
47	1003x	logger <- futile.logger::flog.logger(name = "crmPack")
48	1003x	unname(logger$threshold == futile.logger::TRACE)
49		}
50
51		#' @describeIn enable_logging A simple wrapper of
52		#' [futile.logger::flog.trace()] that prints a log message in the `crmPack`
53		#' logger.
54		#'
55		#' @inheritParams futile.logger::flog.trace
56		#'
57		#' @export
58		#'
59		log_trace <- function(msg, ..., capture = FALSE) {
60	1529x	assert_string(msg)
61	1529x	assert_flag(capture)
62
63	1529x	futile.logger::flog.trace(msg = msg, ..., name = "crmPack", capture = capture)
64		}

1		#' @include McmcOptions-class.R
2		NULL
3
4		# size ----
5
6		## generic ----
7
8		#' Size of an Object
9		#'
10		#' @description `r lifecycle::badge("stable")`
11		#'
12		#' A method that computes the size of a given object. This can be for instance
13		#' a size of a MCMC sample, or the size of a cohort. See the help of a specific
14		#' method for more details.
15		#'
16		#' @param object (`McmcOptions` or `Samples` or `CohortSize`)\cr an object
17		#' for which the size is computed.
18		#' @param ... further arguments passed to `size` specific methods.
19		#'
20		#' @return A size of a given object.
21		#' @export
22		#'
23		setGeneric(
24		name = "size",
25		def = function(object, ...) {
26	92281x	standardGeneric("size")
27		},
28		valueClass = "integer"
29		)
30
31		## McmcOptions ----
32
33		#' @describeIn size compute the number of MCMC samples based on `McmcOptions`
34		#' object.
35		#' @aliases size-McmcOptions
36		#' @example examples/McmcOptions-methods-size.R
37		setMethod(
38		f = "size",
39		signature = signature(object = "McmcOptions"),
40		definition = function(object, ...) {
41	47086x	iterations_relative <- object@iterations - object@burnin
42	47086x	if (iterations_relative <= 0) {
43	!	return(0L)
44		}
45	47086x	as.integer(floor(iterations_relative / object@step))
46		}
47		)
48
49		# saveSample ----
50
51		## generic ----
52
53		#' Determining if this Sample Should be Saved
54		#'
55		#' @description `r lifecycle::badge("stable")`
56		#'
57		#' A method that determines if a sample from a given `iteration` should be
58		#' saved. The sample should be saved if and only if:
59		#' it is not in burn-in period and it matches the `step`.
60		#'
61		#' @param object (`McmcOptions`)\cr object based on which the answer is
62		#' determined.
63		#' @param iteration (`count`)\cr the current iteration index.
64		#' @param ... not used.
65		#' @return `TRUE` if this sample should be saved.
66		#' @export
67		#'
68		setGeneric(
69		name = "saveSample",
70		def = function(object, iteration, ...) {
71	21734x	standardGeneric("saveSample")
72		},
73		valueClass = "logical"
74		)
75
76		## McmcOptions ----
77
78		#' @describeIn saveSample determine if a sample should be saved.
79		#' @aliases saveSample-McmcOptions
80		#' @example examples/McmcOptions-methods-saveSample.R
81		setMethod(
82		f = "saveSample",
83		signature = signature(object = "McmcOptions"),
84		definition = function(object, iteration, ...) {
85	21734x	iteration_relative <- iteration - object@burnin
86	21734x	iteration_relative > 0 && ((iteration_relative %% object@step) == 0)
87		}
88		)

1		#' Helpers for stripping expressions of `covr`-inserted trace code
2		#'
3		#' Workarounds to allow the package to continue to work while running `covr`
4		#' with minimal changes to the package code.
5		#'
6		#' @details
7		#' When using `covr`, the source code for package objects are modified to add
8		#' callbacks for each expression to log its execution. Given an arbitrary
9		#' expression, such as:
10		#'
11		#' expr
12		#'
13		#' The code will be modified before executing any package code to look like:
14		#'
15		#' if (TRUE) {
16		#' covr:::count("file.R:1:2:3:4:5:6:7:8")
17		#' expr
18		#' }
19		#'
20		#' These functions are used for stripping expressions of this code so that the
21		#' package continues to work as intended while running tests as part of running
22		#' `covr` to calculate package coverage.
23		#'
24		#' This method is non-exhaustive, covering only a subset of `covr`'s tracing
25		#' behaviors necessary for this package.
26		#'
27		#' @param expr (`language`)\cr an R expression or call to test or strip of
28		#' `covr` trace counters.
29		#'
30		#' @return A logical value or transformed expression with calls to
31		#' `covr:::count` removed.
32		#'
33		#' @name h_covr_helpers
34		#' @keywords internal
35		#'
36		NULL
37
38		#' @describeIn h_covr_helpers
39		#' Determine whether `covr` is currently running
40		h_covr_active <- function() {
41	95172x	identical(Sys.getenv("R_COVR"), "true")
42		}
43
44		#' @describeIn h_covr_helpers
45		#' Remove `covr` traces from an expression
46		h_covr_detrace <- function(expr) {
47	93778x	if (!h_covr_active()) {
48	2x	return(expr)
49		}
50
51	93776x	if (is.function(expr)) {
52	9x	body(expr) <- h_covr_detrace(body(expr))
53	9x	return(expr)
54		}
55
56	93767x	detrace <- function(x) {
57		# returns "missing" expression to avoid errors with calls
58	93767x	if (identical(x, bquote())) {
59	416x	return(x)
60		}
61
62	93351x	x <- h_covr_detrace_call(x)
63	46222x	if (is.call(x)) x[-1] <- lapply(x[-1], h_covr_detrace)
64	93351x	x
65		}
66
67	93767x	detrace(expr)
68		}
69
70		#' @describeIn h_covr_helpers
71		#' Determine whether the current expression is a `covr`-modified expression
72		h_is_covr_trace <- function(expr) {
73		# Matches `if (TRUE) { covr:::count(<trace>); <expr> }` (see covr:::trace_calls).
74	93356x	is.call(expr) &&
75	93356x	expr[[1]] == "if" &&
76	93356x	expr[[2]] == quote(TRUE) &&
77	93356x	expr[[3]][[1]] == "{" &&
78	93356x	length(expr[[3]] >= 3) &&
79	93356x	is.call(expr[[3]][[2]]) &&
80	93356x	expr[[3]][[2]][[1]] == call(":::", as.symbol("covr"), as.symbol("count"))
81		}
82
83		#' @describeIn h_covr_helpers
84		#' Extract the original expression from a `covr`-modified expression
85		h_covr_detrace_call <- function(expr) {
86	5583x	if (h_is_covr_trace(expr)) expr[[3]][[3]] else expr
87		}

1		#' @include helpers.R
2		#' @include McmcOptions-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# McmcOptions ----
7
8		## class ----
9
10		#' `McmcOptions`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`McmcOptions`] is a class for the three canonical MCMC options as well as
15		#' Random Number Generator settings.
16		#'
17		#' @slot iterations (`count`)\cr number of MCMC iterations.
18		#' @slot burnin (`count`)\cr number of burn-in iterations which are not saved.
19		#' @slot step (`count`)\cr only every `step`-th iteration is saved after
20		#' the `burnin`. In other words, a sample from iteration
21		#' `i = 1,...,iterations`, is saved if and only if
22		#' `(i - burnin) mod step = 0`.\cr
23		#' For example, for `iterations = 6`, `burnin = 0` and `step = 2`, only
24		#' samples from iterations `2,4,6` will be saved.
25		#' @slot rng_kind (`string`)\cr a Random Number Generator (RNG) type used by
26		#' [`rjags`]. It must be one out of the following four values:
27		#' `base::Wichmann-Hill`, `base::Marsaglia-Multicarry`,
28		#' `base::Super-Duper`, `base::Mersenne-Twister`, or `NA_character_`.
29		#' If it is `NA_character_` (default), then the RNG kind will be chosen by
30		#' [`rjags`].
31		#' @slot rng_seed (`number`)\cr a Random Number Generator (RNG) seed
32		#' used by [`rjags`] for a chosen `rng_kind`. It must be an integer scalar or
33		#' `NA_integer_`, which means that the seed will be chosen by [`rjags`].
34		#'
35		#' @aliases McmcOptions
36		#' @export
37		#'
38		.McmcOptions <- setClass(
39		Class = "McmcOptions",
40		slots = c(
41		iterations = "integer",
42		burnin = "integer",
43		step = "integer",
44		rng_kind = "character",
45		rng_seed = "integer"
46		),
47		prototype = prototype(
48		iterations = 1000L,
49		burnin = 100L,
50		step = 2L,
51		rng_kind = NA_character_,
52		rng_seed = NA_integer_
53		),
54		contains = "CrmPackClass",
55		validity = v_mcmc_options
56		)
57
58		## constructor ----
59
60		#' @rdname McmcOptions-class
61		#'
62		#' @param burnin (`count`)\cr number of burn-in iterations which are not saved.
63		#' @param step (`count`)\cr only every step-th iteration is saved after
64		#' the burn-in.
65		#' @param samples (`count`)\cr number of resulting samples.
66		#' @param rng_kind (`string`)\cr the name of the RNG type. Possible types are:
67		#' `Wichmann-Hill`, `Marsaglia-Multicarry`, `Super-Duper`, `Mersenne-Twister`.
68		#' If it is `NA` (default), then the RNG kind will be chosen by `[rjags`].
69		#' @param rng_seed (`number`)\cr RNG seed corresponding to chosen `rng_kind`.
70		#' It must be an integer value or `NA` (default), which means that the seed
71		#' will be chosen by `[rjags`].
72		#'
73		#' @export
74		#' @example examples/McmcOptions-class-McmcOptions.R
75		#'
76		McmcOptions <- function(burnin = 1e4L,
77		step = 2L,
78		samples = 1e4L,
79		rng_kind = NA_character_,
80		rng_seed = NA_integer_) {
81	2361x	assert_count(burnin, positive = TRUE)
82	2361x	assert_count(step, positive = TRUE)
83	2361x	assert_count(samples, positive = TRUE)
84	2361x	assert_string(rng_kind, na.ok = TRUE)
85	2361x	assert_count(rng_seed, na.ok = TRUE)
86
87	2361x	if (!is.na(rng_kind)) {
88	344x	rng_kind <- paste0("base::", rng_kind)
89		} else {
90	2017x	rng_kind <- NA_character_
91		}
92	2361x	if (!is.na(rng_seed)) {
93	343x	rng_seed <- as.integer(rng_seed)
94		} else {
95	2018x	rng_seed <- NA_integer_
96		}
97
98	2361x	.McmcOptions(
99	2361x	iterations = as.integer(burnin + (step * samples)),
100	2361x	burnin = as.integer(burnin),
101	2361x	step = as.integer(step),
102	2361x	rng_kind = rng_kind,
103	2361x	rng_seed = as.integer(rng_seed)
104		)
105		}
106
107		## default constructor ----
108
109		#' @rdname McmcOptions-class
110		#' @note Typically, end users will not use the `.DefaultMcmcOptions()` function.
111		#' @export
112		.DefaultMcmcOptions <- function() {
113	21x	McmcOptions(
114	21x	burnin = 250,
115	21x	samples = 1000
116		)
117		}

1		# nolint start
2
3		#####################################################################################
4		## Author: Daniel Sabanes Bove [sabanesd at* roche . com]
5		## Project: Object-oriented implementation of CRM designs
6		##
7		## Time-stamp: <[crmPack-package.R] by DSB Mon 11/05/2015 17:47>
8		##
9		## Description:
10		## Package description.
11		##
12		## History:
13		## 29/01/2014 file creation
14		#####################################################################################
15
16		#' Object-oriented implementation of CRM designs
17		#'
18		#' @name crmPack-package
19		#' @aliases crmPack
20		#' @docType package
21		#' @title Object-oriented implementation of CRM designs
22		#' @import checkmate
23		#' @import ggplot2
24		#' @import methods
25		#' @import tibble
26		#' @importFrom grid grid.draw
27		#' @importFrom gridExtra arrangeGrob
28		#' @importFrom graphics plot hist legend lines matlines matplot
29		#' @importFrom stats binomial coef cov2cor gaussian glm lm median model.matrix
30		#' optim pgamma plogis pnorm qgamma qlogis qnorm quantile rbinom rgamma
31		#' approxfun rnorm runif uniroot var vcov step mad pbeta dbeta dgamma
32		#' setNames
33		#' @importFrom utils data head tail capture.output
34		#' @importFrom lifecycle badge
35		#' @importFrom rjags jags.model jags.samples
36		#' @importFrom futile.logger flog.threshold flog.logger flog.trace TRACE FATAL
37		#' @importFrom knitr knit_print
38		#' @importFrom kableExtra kbl add_header_above column_spec collapse_rows
39		#' kable_styling add_footnote kable
40		#'
41		#' @keywords package
42		#' @references Sabanes Bove D, Yeung WY, Palermo G, Jaki T (2019).
43		#' "Model-Based Dose Escalation Designs in R with crmPack."
44		#' Journal of Statistical Software, 89(10), 1-22.
45		#' doi:10.18637/jss.v089.i10 (URL: http://doi.org/10.18637/jss.v089.i10).
46		{}
47
48		##' @keywords internal
49		.onAttach <- function(libname, pkgname) {
50	3x	packageStartupMessage(
51	3x	"Type crmPackHelp() to open help browser\n",
52	3x	"Type crmPackExample() to open example\n"
53		)
54		}
55
56		## need to declare global variable / function
57		## names in order to avoid R CMD check notes:
58		globalVariables(c(
59		"log.betaZ",
60		"precW",
61		"pow",
62		"nObs",
63		"betaZ",
64		"x",
65		"betaW",
66		"xLevel",
67		"precW",
68		"z",
69		"nGrid",
70		"doseGrid",
71		"betaWintercept",
72		"delta",
73		"deltaStart",
74		"delta2",
75		"Effsamples",
76		"logit<-",
77		"rho0",
78		"alpha0",
79		"delta0",
80		"alpha1",
81		"delta1",
82		"inverse",
83		"priorCov",
84		"theta",
85		"comp0",
86		"w",
87		"DLTs",
88		"y",
89		"group",
90		"annotate",
91		"probSamples",
92		"prec",
93		"nu",
94		"samples",
95		"Type",
96		"patient",
97		"toxicity",
98		"ID",
99		"biomarker",
100		"traj",
101		"Statistic",
102		"perc",
103		"..density..",
104		"middle",
105		"lower",
106		"upper",
107		"middleBiomarker",
108		"lowerBiomarker",
109		"upperBiomarker",
110		"nObsshare",
111		"xshare",
112		"yshare",
113		"thisProb.PL",
114		"thisMeanEff.PL",
115		"thisSize.PL",
116		"probit<-",
117		"refDose",
118		"Tmax",
119		"u",
120		"eps",
121		"h",
122		"lambda",
123		"cadj",
124		"A",
125		"lambda_p",
126		"cond",
127		"t0",
128		"tend",
129		"t0_case",
130		"tend_case",
131		"yhat",
132		"ref_dose",
133		"comp",
134		"X",
135		"skel_probs",
136		"is_combo",
137		"results",
138		"k",
139		"value",
140		"Parameter",
141		"intervals",
142		"Group",
143		"Tox"
144		))
145
146		# nolint end

1		#' Apply a Function to Subsets of Data Frame.
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' `dapply` splits the data `df` into the subsets defined by `f`,
6		#' and applies function `FUN` to each of the subset.
7		#' All the results are row-binded and returned as `data.frame` object.
8		#'
9		#' @param df (`data frame`)\cr data set to be divided into groups.
10		#' @param f (`factor` or `formula` or `list`)\cr a factor in the sense that
11		#' `as.factor(f)` defines the grouping, or a `list` of such factors in which
12		#' case their interaction is used for the grouping. `f` can also be a formula
13		#' of the form `~ g1 + ... + gk` to split by the interaction of the variables
14		#' `g1, ..., gk`. This parameter is passed directly into [split()] function.
15		#' @param FUN (`function`)\cr the function to be applied to each subset of `df`
16		#' defined by `f`.
17		#' @param ... parameters passed to [lapply()], which is used when applying a
18		#' function `FUN` over groups defined by `f`.
19		#'
20		#' @return The [`data.frame`] object with results from `FUN`.
21		#'
22		#' @export
23		#' @example examples/utils-dapply.R
24		#'
25		dapply <- function(df, f, FUN, ...) {
26	11x	assert_data_frame(df)
27
28	11x	list_df <- split(df, f = f)
29	11x	list_df <- lapply(list_df, FUN, ...)
30	11x	df2 <- do.call(rbind, list_df)
31	11x	rownames(df2) <- NULL
32	11x	df2
33		}

1		#' @include McmcOptions-methods.R
2		NULL
3
4		# v_samples ----
5
6		#' Internal Helper Functions for Validation of [`Samples`] Objects
7		#'
8		#' @description These functions are only used internally to validate the format
9		#' of an input [`Samples`] or inherited classes and therefore not exported.
10		#'
11		#' @name v_samples_objects
12		#' @param object (`Samples`)\cr object to validate.
13		#' @return A `character` vector with the validation failure messages, or `TRUE`
14		#' in case validation passes.
15		NULL
16
17		#' @describeIn v_samples_objects validates that the [`Samples`] object contains
18		#' valid `data` slot.
19		v_samples <- function(object) {
20	7x	v <- Validate()
21	7x	v$check(
22	7x	all(sapply(object@data, NROW) == size(object@options)),
23	7x	"Every element in data must be of the same length (no. of rows) as the sample size was"
24		)
25	7x	v$check(
26	7x	all(sapply(object@data, test_numeric, finite = TRUE, any.missing = FALSE)),
27	7x	"Every element in data must be a finite object of type integer or double"
28		)
29	7x	v$result()
30		}

1		#' @include McmcOptions-class.R
2		#' @include Samples-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# Samples ----
7
8		## class ----
9
10		#' `Samples`
11		#'
12		#' @description `r lifecycle::badge("stable")`
13		#'
14		#' [`Samples`] is the class to store the MCMC samples.
15		#'
16		#' @slot data (`list`)\cr MCMC samples of the parameter. Each entry in this list
17		#' must be a vector (in case of a scalar parameter) or matrix (in case of a
18		#' vector-valued parameter) with samples.
19		#' In case of matrix, every row is a separate sample, while columns correspond
20		#' to the dimension of the parameter.
21		#' @slot options (`McmcOptions`)\cr MCMC options that were used to generate the
22		#' samples.
23		#'
24		#' @aliases Samples
25		#' @export
26		#'
27		.Samples <- setClass(
28		Class = "Samples",
29		slots = c(
30		data = "list",
31		options = "McmcOptions"
32		),
33		prototype = prototype(
34		data = list(),
35		options = McmcOptions()
36		),
37		contains = "CrmPackClass",
38		validity = v_samples
39		)
40
41		## constructor ----
42
43		#' @rdname Samples-class
44		#'
45		#' @param data see slot definition.
46		#' @param options see slot definition.
47		#'
48		#' @export
49		#' @example examples/Samples-class.R
50		#'
51		Samples <- function(data, options) {
52	2733x	new("Samples", data = data, options = options)
53		}
54
55		## default constructor ----
56
57		#' @rdname Samples-class
58		#' @note Typically, end users will not use the `.DefaultSamples()` function.
59		#' @export
60		.DefaultSamples <- function() {
61	4x	mcmc(
62	4x	data = .DefaultData(),
63	4x	model = .DefaultLogisticLogNormal(),
64	4x	options = .DefaultMcmcOptions()
65		)
66		}

1		#' @include helpers.R
2		#' @include ModelParams-validity.R
3		#' @include CrmPackClass-class.R
4		NULL
5
6		# ModelParamsNormal ----
7
8		## class ----
9
10		#' `ModelParamsNormal`
11		#'
12		#' @description `r lifecycle::badge("experimental")`
13		#'
14		#' [`ModelParamsNormal`] is the class for a bivariate normal model parameters,
15		#' i.e. the mean vector, covariance matrix and precision matrix.
16		#' The precision matrix is an inverse of the covariance matrix in the
17		#' `JAGS` and it is computed internally by the object constructor function.
18		#'
19		#' @slot mean (`numeric`)\cr the mean vector.
20		#' @slot cov (`matrix`)\cr the covariance matrix.
21		#' @slot prec (`matrix`)\cr the precision matrix, which is an inverse matrix of the `cov`.
22		#'
23		#' @seealso [`ModelLogNormal`], [`LogisticNormalMixture`].
24		#'
25		#' @aliases ModelParamsNormal
26		#' @export
27		#'
28		.ModelParamsNormal <- setClass(
29		Class = "ModelParamsNormal",
30		slots = c(
31		mean = "numeric",
32		cov = "matrix",
33		prec = "matrix"
34		),
35		contains = "CrmPackClass",
36		validity = v_model_params_normal
37		)
38
39		## constructor ----
40
41		#' @rdname ModelParamsNormal-class
42		#'
43		#' @param mean (`numeric`)\cr the prior mean vector.
44		#' @param cov (`matrix`)\cr the prior covariance matrix. The precision matrix
45		#' `prec` is internally calculated as an inverse of `cov`.
46		#'
47		#' @export
48		#' @examples
49		#' ModelParamsNormal(mean = c(1, 6), cov = diag(2))
50		ModelParamsNormal <- function(mean, cov) {
51	684x	assert_matrix(
52	684x	cov,
53	684x	mode = "numeric",
54	684x	any.missing = FALSE,
55	684x	nrows = length(mean),
56	684x	ncols = length(mean)
57		)
58		# To ensure that `cov` is invertible:
59	684x	assert_true(h_is_positive_definite(cov, length(mean)))
60
61	684x	.ModelParamsNormal(
62	684x	mean = mean,
63	684x	cov = cov,
64	684x	prec = solve(cov)
65		)
66		}
67
68		## default constructor ----
69
70		#' @rdname ModelParamsNormal-class
71		#' @note Typically, end users will not use the `.ModelPAramsNormal()` function.
72		#' @export
73		.DefaultModelParamsNormal <- function() {
74	4x	ModelParamsNormal(
75	4x	mean = c(1, 0),
76	4x	cov = matrix(c(1, 0, 0, 1), nrow = 2)
77		)
78		}